diff --git a/.gitignore b/.gitignore index eca261d36e..876fb30491 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,22 @@ configure.wrf* *.backup *.f90 + +# Out-of-source build locations +_build* +wrf_config.cmake + +# Executables when not featuring .exe suffix +ndown +real +tc +ideal +wrf + +# Model inputs/outputs +wrfbdy_d* +wrfinput_d* +wrfout_d* +*.nc +rsl.out.* +rsl.error.* diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000000..d1a1297f2f --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,931 @@ +cmake_minimum_required( VERSION 3.20 ) +cmake_policy( SET CMP0118 NEW ) + +enable_language( C ) +enable_language( CXX ) +enable_language( Fortran ) + +project( WRF ) +set( EXPORT_NAME ${PROJECT_NAME} ) + +if ( DEFINED CMAKE_TOOLCHAIN_FILE ) + set( WRF_CONFIG ${CMAKE_TOOLCHAIN_FILE} ) + # message( STATUS "Loading configuration file... : ${WRF_CONFIG}" ) + # include( ${WRF_CONFIG} ) +endif() + +# list( APPEND CMAKE_MODULE_PATH ) +list( APPEND CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake/ ${PROJECT_SOURCE_DIR}/cmake/modules ) + +# Use link paths as rpaths +set( CMAKE_INSTALL_RPATH_USE_LINK_PATH TRUE ) +set( CMAKE_Fortran_PREPROCESS ON ) + +# This is always set +list( APPEND CMAKE_C_PREPROCESSOR_FLAGS -P -nostdinc -traditional ) + +include( CMakePackageConfigHelpers ) +include( CheckIPOSupported ) +include( c_preproc ) +include( m4_preproc ) +include( target_copy ) +include( confcheck ) +include( gitinfo ) +include( printOption ) +include( wrf_case_setup ) +include( wrf_get_version ) + +check_ipo_supported( RESULT IPO_SUPPORT ) + +# First grab git info +wrf_git_commit( + RESULT_VAR GIT_VERSION + WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} + ) + +# Configure file for usage +configure_file( + ${PROJECT_SOURCE_DIR}/cmake/template/commit_decl.cmake + ${PROJECT_BINARY_DIR}/inc/commit_decl + @ONLY + ) + +# Grab version info +wrf_get_version( ${PROJECT_SOURCE_DIR}/README ) + +################################################################################ +## +## Options that can be user configured +## +################################################################################ +# Mode configuration + +set( OPTIMIZATION_LEVEL "" ) +set( WRF_OS "" ) +set( WRF_MACH "" ) + +if ( "${CMAKE_BUILD_TYPE}" STREQUAL "" ) + set( CMAKE_BUILD_TYPE Release ) + message( STATUS "Set default build type to ${CMAKE_BUILD_TYPE}" ) +endif() +################################################################################ +## WRF Core selection +################################################################################ +set( WRF_CORE_OPTIONS + # Options listed here + ARW + CONVERT # This exists in compile but not configure + DA # Var directory + DA_4D_VAR + PLUS + ) + +set( WRF_CORE "" CACHE STRING "WRF_CORE" ) +if ( "${WRF_CORE}" STREQUAL "" ) + # Set default WRF_CORE + list( GET WRF_CORE_OPTIONS 0 WRF_CORE ) +endif() + +################################################################################ +## WRF Nesting selection +################################################################################ +set( WRF_NESTING_OPTIONS + # Options listed here + NONE + BASIC + MOVES + VORTEX + ) + +set( WRF_NESTING "" CACHE STRING "WRF_NESTING" ) +if ( "${WRF_NESTING}" STREQUAL "" ) + # Set default WRF_NESTING + list( GET WRF_NESTING_OPTIONS 0 WRF_NESTING ) +endif() + +################################################################################ +## WRF Case selection +##!TODO Maybe one day make it so this doesn't need to be a selection and all are +## always built? +################################################################################ +set( WRF_CASE_OPTIONS + # Options listed here + EM_REAL # make this the default + # EM_IDEAL # Technically doable but does anyone build this? It is not a target option in make + EM_FIRE + EM_SCM_XY + EM_TROPICAL_CYCLONE + EM_HELDSUAREZ + + # These are sub-categories of ideal - Keep these lower in the list + EM_B_WAVE # Keep this one here as it is used to check index + EM_GRAV2D_X + EM_HILL2D_X + EM_LES + EM_QUARTER_SS + EM_SEABREEZE2D_X + EM_CONVRAD + EM_SQUALL2D_X + EM_SQUALL2D_Y + ) + +set( WRF_CASE "" CACHE STRING "WRF_CASE" ) +if ( "${WRF_CASE}" STREQUAL "" ) + # Set default WRF_CASE + list( GET WRF_CASE_OPTIONS 0 WRF_CASE ) +endif() + +# DO NOT USE OPTION - IT DOES NOT WORK AS ANTICIPATED EVEN WHEN CLEARING CACHE - YOU HAVE BEEN WARNED +# If you add anything here, the description should be the name itself - this helps the configuration script +set( USE_DOUBLE OFF CACHE BOOL "USE_DOUBLE" ) +set( USE_MPI OFF CACHE BOOL "USE_MPI" ) +set( USE_OPENMP OFF CACHE BOOL "USE_OPENMP" ) +set( USE_HDF5 OFF CACHE BOOL "USE_HDF5" ) +set( USE_JASPER OFF CACHE BOOL "USE_JASPER" ) +set( USE_PIO OFF CACHE BOOL "USE_PIO" ) +set( USE_IPO OFF CACHE BOOL "USE_IPO" ) + + +set( ENABLE_CHEM OFF CACHE BOOL "ENABLE_CHEM" ) +set( ENABLE_CMAQ OFF CACHE BOOL "ENABLE_CMAQ" ) +set( ENABLE_CTSM OFF CACHE BOOL "ENABLE_CTSM" ) +set( ENABLE_DFI_RADAR OFF CACHE BOOL "ENABLE_DFI_RADAR" ) +set( ENABLE_HYDRO OFF CACHE BOOL "ENABLE_HYDRO" ) +set( ENABLE_KPP OFF CACHE BOOL "ENABLE_KPP" ) +set( ENABLE_MARS OFF CACHE BOOL "ENABLE_MARS" ) +set( ENABLE_TERRAIN OFF CACHE BOOL "ENABLE_TERRAIN" ) +set( ENABLE_TITAN OFF CACHE BOOL "ENABLE_TITAN" ) +set( ENABLE_VENUS OFF CACHE BOOL "ENABLE_VENUS" ) + +# What do these defines even do if they are always on???? +set( USE_ALLOCATABLES ON CACHE BOOL "USE_ALLOCATABLES" ) +set( wrfmodel ON CACHE BOOL "wrfmodel" ) +set( GRIB1 ON CACHE BOOL "GRIB1" ) +set( INTIO ON CACHE BOOL "INTIO" ) +set( KEEP_INT_AROUND ON CACHE BOOL "KEEP_INT_AROUND" ) +set( LIMIT_ARGS ON CACHE BOOL "LIMIT_ARGS" ) + +# Toggles, how do we want to best address these options? Environment vars are not +# the best +set( WRFIO_NCD_NO_LARGE_FILE_SUPPORT OFF CACHE BOOL "WRFIO_NCD_NO_LARGE_FILE_SUPPORT" ) +set( FORCE_NETCDF_CLASSIC OFF CACHE BOOL "FORCE_NETCDF_CLASSIC" ) +set( BUILD_RRTMG_FAST OFF CACHE BOOL "BUILD_RRTMG_FAST" ) +set( BUILD_RRTMK OFF CACHE BOOL "BUILD_RRTMK" ) +set( BUILD_SBM_FAST ON CACHE BOOL "BUILD_SBM_FAST" ) +set( SHOW_ALL_VARS_USED OFF CACHE BOOL "SHOW_ALL_VARS_USED" ) + + +# TODO investigate if this needs set +# Not cached, cannot be changed, do not touch +set( USE_M4 ON ) +# Same thing -what do these defines even do if they are always on???? +set( NMM_CORE OFF ) +set( NETCDF ON ) + + +# Special internal flag for profiling compilation +set( PROFILE_COMPILATION OFF CACHE BOOL "PROFILE_COMPILATION" ) + + +# From arch/preamble +#### Single location for defining total number of domains. You need +#### at least 1 + 2*(number of total nests). For example, 1 coarse +#### grid + three fine grids = 1 + 2(3) = 7, so MAX_DOMAINS=7. +set( MAX_DOMAINS_F 21 ) + + +#### DM buffer length for the configuration flags. + +set( CONFIG_BUF_LEN 65536 ) + +#### Size of bitmasks (in 4byte integers) of stream masks for WRF I/O + +set( MAX_HISTORY 25 ) + +set( IWORDSIZE 4 ) +set( DWORDSIZE 8 ) +set( LWORDSIZE 4 ) + + +######################## + +################################################################################ +## +## Load options selected and any ancillary logic +## +################################################################################ + +# Check WRF options +if ( NOT ${WRF_CORE} IN_LIST WRF_CORE_OPTIONS ) + message( FATAL_ERROR "WRF Core option not recognized : ${WRF_CORE}" ) +endif() + +if ( NOT ${WRF_NESTING} IN_LIST WRF_NESTING_OPTIONS ) + message( FATAL_ERROR "WRF Nesting option not recognized : ${WRF_NESTING}" ) +endif() + +if ( NOT ${WRF_CASE} IN_LIST WRF_CASE_OPTIONS ) + message( FATAL_ERROR "WRF Case option not recognized : ${WRF_CASE}" ) +endif() + +# Handle selection +set( EM_CORE 1 ) +# Far easier to write this one as normal logic rather than generator expression +if( ${WRF_CORE} STREQUAL "CONVERT" OR ${WRF_CORE} STREQUAL "COAMPS" ) + set( EM_CORE 0 ) +endif() + +set( MOVE_NESTS 0 ) +# Far easier to write this one as normal logic rather than generator expression +if( ${WRF_NESTING} STREQUAL "MOVES" OR ${WRF_NESTING} STREQUAL "VORTEX" ) + set( MOVE_NESTS 1 ) +endif() + +if ( ${ENABLE_KPP} AND NOT ${ENABLE_CHEM} ) + message( WARNING "ENABLE_KPP requires ENABLE_CHEM but is not set, ignoring" ) +endif() + + +# Additional information on the type of case we are compiling +string( TOLOWER ${WRF_CASE} WRF_CASE_FOLDER ) +string( REPLACE "em_" "" WRF_CASE_MODULE ${WRF_CASE_FOLDER} ) + +# Find if it is a specialized ideal case or general +list( FIND WRF_CASE_OPTIONS EM_B_WAVE START_GENERAL_IDEAL_CASE_IDX ) +list( FIND WRF_CASE_OPTIONS ${WRF_CASE} CURRENT_CASE_IDX ) +set( WRF_GENERAL_IDEAL_CASE TRUE ) +if ( ${CURRENT_CASE_IDX} LESS ${START_GENERAL_IDEAL_CASE_IDX} ) + set( WRF_GENERAL_IDEAL_CASE FALSE ) +endif() + +if ( NOT ${WRFIO_NCD_NO_LARGE_FILE_SUPPORT} ) + message( STATUS "netCDF large file support not suppressed, if available it will be used" ) +endif() + +# Hydro option requires MPI +if ( ${ENABLE_HYDRO} AND NOT ${USE_MPI} ) + message( STATUS "WRF Hydro requires MPI usage" ) + set( USE_MPI ON CACHE BOOL "Required by configuration" FORCE ) +endif() + +# Handle double promotion - doing this here instead of from config.cmake toolchain +# file since the double promotion logic is a nightmare +list( FIND WRF_CORE_OPTIONS ${WRF_CORE} CURRENT_WRF_CORE_IDX ) +list( FIND WRF_CORE_OPTIONS "DA" START_DA_IDX ) +# DA + WRF PLUS cores require double precision +if ( ${CURRENT_WRF_CORE_IDX} GREATER_EQUAL ${START_DA_IDX} AND NOT ${USE_DOUBLE} ) + # if ( # Apparently set regardless of compiler + # ${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU" OR + # ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Fujitsu" ) + message( STATUS "DA and PLUS Core builds require double precision" ) + set( USE_DOUBLE ON CACHE BOOL "Required by configuration" FORCE ) + # endif() +endif() + +if ( ${USE_DOUBLE} ) + set( RWORDSIZE 8 ) + if ( ${BUILD_SBM_FAST} ) + set( BUILD_SBM_FAST OFF CACHE BOOL "Required by configuration" FORCE ) + message( STATUS "BUILD_SBM_FAST does not support double, turning off" ) + endif() +else() + set( RWORDSIZE 4 ) +endif() + +math( EXPR RWORDSIZE_B "8 * ${RWORDSIZE}" ) + + +# Check if IPO usage +if ( ${USE_IPO} ) + if ( NOT ${IPO_SUPPORT} ) + message( STATUS "IPO/LTO not supported, request ignored" ) + set( USE_IPO OFF CACHE BOOL "Required by configuration" FORCE ) + endif() +endif() + +################################################################################ +## +## Now find packages that cross-compilation is potentially handled +## +################################################################################ +# If nesting is enabled, DM_PARALLEL must be set, but if this is a non-MPI compilation +# we must stub its usage +list( FIND WRF_NESTING_OPTIONS ${WRF_NESTING} CURRENT_NESTING_IDX ) + +# If MPI or nesting +set( USE_RSL_LITE OFF ) +if ( ${USE_MPI} ) + # Through ***MUCH*** debugging, if utilizing MPI__COMPILER + # https://cmake.org/cmake/help/latest/module/FindMPI.html#variables-for-locating-mpi + # the find logic makes a mess of things by utilizing -show[me] + # Which may or may not get polluted by the environment + # It still technically finds MPI but the output is nonintuitive + # saying things like hdf5 or pthread + find_package( MPI REQUIRED COMPONENTS Fortran C ) + add_compile_definitions( + USE_MPI=1 + DM_PARALLEL + ) + + if ( DEFINED WRF_MPI_Fortran_FLAGS AND NOT "${WRF_MPI_Fortran_FLAGS}" STREQUAL "" ) + add_compile_options( + $<$:${WRF_MPI_Fortran_FLAGS}> + ) + endif() + + if ( DEFINED WRF_MPI_C_FLAGS AND NOT "${WRF_MPI_C_FLAGS}" STREQUAL "" ) + add_compile_options( + $<$:${WRF_MPI_C_FLAGS}> + ) + endif() + + # Check if MPI in all its glory has forced IPO down our throats due to hard-coding the wrapper flags + # https://www.open-mpi.org/faq/?category=mpi-apps#why-no-rpath LOL! + # Quote "The default installation of Open MPI tries very hard to not include any non-essential flags in the wrapper compilers" + # Okay, yea sure. Maybe it's the distro's lib config that does add all the bloatware flags + if ( NOT ${USE_IPO} ) + # get compile info + message( STATUS "Checking if MPI requires IPO" ) + foreach( IPO_FLAG IN LISTS CMAKE_Fortran_COMPILE_OPTIONS_IPO ) + string( FIND "${MPI_Fortran_COMPILE_OPTIONS}" ${IPO_FLAG} MPI_FORCE_IPO ) + # Note we are not using IN_LIST since certain IPO settings might not exactly match (e.g. -flto vs -flto=auto) + if ( NOT ${MPI_FORCE_IPO} EQUAL -1 ) + # An IPO flag was found + if ( ${IPO_SUPPORT} ) + message( STATUS "NOTE: ${MPI_Fortran_COMPILER} requires IPO flags be enabled, forcing USE_IPO=ON" ) + set( USE_IPO ON CACHE BOOL "Required by MPI" FORCE ) + break() + else() + message( FATAL_ERROR "${MPI_Fortran_COMPILER} requires IPO support but selected compiler does not support it, would fail to link" ) + endif() + endif() + endforeach() + endif() + + set( USE_RSL_LITE ON ) +# We know NONE is the zero index so compare against that +elseif( ${CURRENT_NESTING_IDX} GREATER 0 ) + add_compile_definitions( + DM_PARALLEL + STUBMPI + ) + set( USE_RSL_LITE ON ) +endif() + +if ( ${USE_OPENMP} ) + find_package( OpenMP REQUIRED COMPONENTS Fortran C ) + add_compile_definitions( USE_OPENMP=1 SM_PARALLEL ) +endif() + +if ( ${USE_M4} ) + find_program( + M4_PROGRAM + m4 + REQUIRED + ) + set( M4_FLAGS ${WRF_M4_FLAGS} -Uinclude -Uindex -Ulen ) +endif() + + + +# HDF5 has some funky weirdness between versions where the casing has changed +# Optional +if ( ${USE_HDF5} ) + find_package( HDF5 ) +endif() + +# Optional for grib2 +if ( ${USE_JASPER} ) + find_package( Jasper 1.900.1...<1.900.24 ) +endif() + +# Optional +if ( ${USE_PIO} ) + find_package( PIO QUIET ) +endif() + +if ( ${ENABLE_TERRAIN} ) + find_package( RPC ) +endif() + +if ( ${ENABLE_CTSM} ) + # Will need our own finder + # find_package( CTSM REQUIRED ) +endif() + +# Will need our own finder +# find_package( GPFS REQUIRED ) + +# Included is a lightweight finder, but we really should switch to using UniData's netCDF cmake config +# The reason these are two separate and not COMPONENTS of one larger package is because that is the way UniData +# has laid out the cmake configs for each respective package +find_package( netCDF REQUIRED ) +find_package( netCDF-Fortran REQUIRED ) + +# Make use of version checking here and not in find_package for previous versions that did not use cmake +if ( ( NOT netCDF_VERSION GREATER_EQUAL "4.1.3" ) OR ( NOT netCDF-Fortran_VERSION GREATER_EQUAL "4.1.3" ) ) + message( FATAL "Please make sure NETCDF versions are 4.1.3 or later. " ) +endif() + +find_package( pnetCDF QUIET ) + +# Attempt to find zlib packaged with netcdf first +set( ZLIB_ROOT ${netCDF_PREFIX} ) +find_package( ZLIB REQUIRED ) +find_package( CURL REQUIRED ) + +################################################################################ +## +## Print out final set of options to be used +## DO NOT MODIFY OPTIONS BEYOND THIS POINT +## +################################################################################ + +if ( DEFINED CMAKE_TOOLCHAIN_FILE ) + print_option( WRF_CONFIG 20 ${BOLD_CYAN} ) +endif() + +print_option( CMAKE_BUILD_TYPE 20 ${BOLD_CYAN} ) + + +print_option( WRF_CORE 20 ${BOLD_CYAN} ) +print_option( WRF_NESTING 20 ${BOLD_CYAN} ) +print_option( WRF_CASE 20 ${BOLD_CYAN} ) + + +print_option( USE_DOUBLE 20 ) +print_option( USE_MPI 20 ) +print_option( USE_OPENMP 20 ) +print_option( USE_IPO 20 ) + +print_option( ENABLE_CHEM 20 ) +print_option( ENABLE_CLM 20 ) +print_option( ENABLE_CMAQ 20 ) +print_option( ENABLE_DFI_RADAR 20 ) +print_option( ENABLE_HYDRO 20 ) +print_option( ENABLE_KPP 20 ) +print_option( ENABLE_MARS 20 ) +print_option( ENABLE_TERRAIN 20 ) +print_option( ENABLE_TITAN 20 ) +print_option( ENABLE_VENUS 20 ) + +print_option( USE_ALLOCATABLES 20 ) +print_option( wrfmodel 20 ) +print_option( GRIB1 20 ) +print_option( INTIO 20 ) +print_option( KEEP_INT_AROUND 20 ) +print_option( LIMIT_ARGS 20 ) + +print_option( FORCE_NETCDF_CLASSIC 20 ) +print_option( BUILD_RRTMG_FAST 20 ) +print_option( BUILD_RRTMK 20 ) +print_option( BUILD_SBM_FAST 20 ) +print_option( SHOW_ALL_VARS_USED 20 ) + +print_option( WRFIO_NCD_NO_LARGE_FILE_SUPPORT 36 ) + +################################################################################ +## +## Set any global cmake options decided by particular configuration +## +################################################################################ +set( CMAKE_INTERPROCEDURAL_OPTIMIZATION ${USE_IPO} ) + +################################################################################ +## +## Configuration checks for features & intrinsices +## +################################################################################ +add_subdirectory( confcheck ) + +################################################################################ +## +## Adjust flags based on compiler and linker used +## +################################################################################ + +# https://stackoverflow.com/a/47927921 +# Define compile options to be inherited for directories +define_property( + SOURCE + PROPERTY COMPILE_FLAGS + INHERITED + BRIEF_DOCS "brief-doc" + FULL_DOCS "full-doc" + ) + +define_property( + DIRECTORY + PROPERTY COMPILE_FLAGS + INHERITED + BRIEF_DOCS "brief-doc" + FULL_DOCS "full-doc" + ) + +# Get current build type flags and put them in there +if ( "${CMAKE_BUILD_TYPE}" STREQUAL "Release" ) + set_directory_properties( + PROPERTIES + COMPILE_FLAGS + $<$:${WRF_FCOPTIM}> + ) +# else() +# # Assume no optimization +# set_directory_properties( +# PROPERTIES +# COMPILE_FLAGS +# $<$:${WRF_FCNOOPT}> +# ) +endif() + + +# This is really ugly but such is the cost of supporting many ways to say the same thing +# https://cmake.org/cmake/help/latest/variable/CMAKE_LANG_COMPILER_ID.html +add_compile_options( + # Use "" and ; specifically to evaluate correctly + # "$<$:>" #@ Absoft Fortran + # "$<$:>" #@ Analog VisualDSP++ + # "$<$:>" #@ Apple Clang + # "$<$:>" #@ ARM Compiler + # "$<$:>" #@ ARM Compiler based on Clang + # "$<$:>" #@ Bruce C Compiler + # "$<$:>" #@ Concurrent Fortran + # "$<$:>" #@ LLVM Clang + "$<$:-s;integer32;-s;real${RWORDSIZE_B}>" #@ Cray Compiler + # "$<$:>" #@ Embarcadero + "$<$,$>:-fdefault-real-${RWORDSIZE}>" #@ Classic Flang Fortran Compiler + # "$<$:>" #@ LLVM Flang Fortran Compiler + "$<$:-CcdRR${RWORDSIZE}>" #@ Fujitsu HPC compiler (Trad mode) + # "$<$:>" #@ Fujitsu HPC compiler (Clang mode) + "$<$:-r${RWORDSIZE};-i4>" #@ G95 Fortran + "$<$,$>:-fdefault-real-${RWORDSIZE}>" #@ GNU Compiler Collection + # "$<$:>" #@ Green Hills Software + # "$<$:>" #@ Hewlett-Packard Compiler + # "$<$:>" #@ IAR Systems + "$<$:-real-size;${RWORDSIZE_B};-i4>" #@ Intel Classic Compiler + "$<$:-real-size;${RWORDSIZE_B};-i4>" #@ Intel LLVM-Based Compiler + # "$<$:>" #@ MCST Elbrus C/C++/Fortran Compiler + # "$<$:>" #@ Microsoft Visual Studio + "$<$:-r${RWORDSIZE};-i4>" #@ NVIDIA HPC Compiler + # "$<$:>" #@ NVIDIA CUDA Compiler + # "$<$:>" #@ Open Watcom + "$<$:-r${RWORDSIZE};-i4>" #@ The Portland Group + "$<$:-r${RWORDSIZE};-i4>" #@ PathScale + # "$<$:>" #@ Small Device C Compiler + # "$<$:>" #@ Oracle Solaris Studio + # "$<$:>" #@ Tasking Compiler Toolsets + # "$<$:>" #@ Texas Instruments + # "$<$:>" #@ Tiny C Compiler + "$<$:-qrealsize=${RWORDSIZE};-qintsize=4>" #@ IBM XL + # "$<$:>" #@ IBM Clang-based XL + # "$<$:>" #@ IBM LLVM-based Compiler + # Todo find how to handle default selection or add new compiler IDs + # unknown how to add support for sxf90 + + # line lengths + "$<$:-ffree-line-length-none>" #@ GNU Compiler Collection + ) + + +# https://stackoverflow.com/a/53155812 +# set( Fortran_COMPILER_ID ${CMAKE_Fortran_COMPILER_ID} ) +# message( STATUS "Set Fortran_COMPILER_ID to : ${Fortran_COMPILER_ID}" ) + + +# Whole project flags +add_compile_options( + # $<$:-cpp> + # Use "" and ; specifically to evaluate correctly + "$<$:-diag-disable;6843>" + $<$,$>:-fallow-argument-mismatch> + $<$,$>:-fallow-invalid-boz> + $<$,$>:-ffree-line-length-none> + + # $,$:-diag-disable;6843> + ) + +if ( ${PROFILE_COMPILATION} ) + message( STATUS "Attemping to add compilation profiling..." ) + add_compile_options( + $<$:-ftime-report> + ) +endif() + +add_compile_definitions( + MAX_DOMAINS_F=${MAX_DOMAINS_F} + CONFIG_BUF_LEN=${CONFIG_BUF_LEN} + MAX_HISTORY=${MAX_HISTORY} + IWORDSIZE=${IWORDSIZE} + DWORDSIZE=${DWORDSIZE} + LWORDSIZE=${LWORDSIZE} + RWORDSIZE=${RWORDSIZE} + # Only define if set, this is to use #ifdef/#ifndef preprocessors + # in code since cmake cannot handle basically any others :( + # https://gitlab.kitware.com/cmake/cmake/-/issues/17398 + $<$:WRF_CHEM=$> + $<$:BUILD_CHEM=$> + $<$:WRF_CMAQ=$> + $<$,$>:WRF_KPP=$> + $<$:WRF_DFI_RADAR=$> + $<$:WRF_TITAN=$> + $<$:WRF_MARS=$> + $<$:WRF_VENUS=$> + $<$:WRF_HYDRO=$> + + # Because once again we need two defines to control one thing + $<$:WRF_USE_CTSM=$> + $<$>:WRF_USE_CLM> + + # If force classic or no nc-4 support enable classic + $<$,$>>:NETCDF_classic=1> + $<$,$>>:WRFIO_NCD_NO_LARGE_FILE_SUPPORT=1> + # May need a check for WRFIO_ncdpar_LARGE_FILE_SUPPORT + + # Now set the opposite in different defines, because why not :) + $<$>,$>:USE_NETCDF4_FEATURES=1> + $<$>,$>:WRFIO_NCD_LARGE_FILE_SUPPORT=1> + + # Could simplify logic to just check if RPC is available but to be explicit + # Does this actually need to check for EM_CORE (Config.pl:443) + # not enable terran or not rpc_found do + # not ( enable terrain and rpc_found ) + $<$,$>>:LANDREAD_STUB> + $<$:TERRAIN_AND_LANDUSE> + + + $<$:USE_ALLOCATABLES> + $<$:wrfmodel> + $<$:GRIB1> + $<$:INTIO> + $<$:KEEP_INT_AROUND> + $<$:LIMIT_ARGS> + + #!TODO Always defined - fix the ambiguous english in these BUILD_*_FAST defines + BUILD_RRTMG_FAST=$ + BUILD_RRTMK=$ + BUILD_SBM_FAST=$ + SHOW_ALL_VARS_USED=$ + + # Alwasys set + NMM_CORE=$ + NMM_MAX_DIM=2600 + NETCDF + + #!TODO Change this to a confcheck + NONSTANDARD_SYSTEM_SUBR + + EM_CORE=${EM_CORE} + WRFPLUS=$> + DA_CORE=$,$>> + # DFI_RADAR=$ + + # Nesting options + $<$:MOVE_NESTS> + $<$>:VORTEX_CENTER> + + # Configuration checks + $<$>:NO_IEEE_MODULE> + $<$>:NO_ISO_C_SUPPORT> + # If flush fails, check if we can fall back to fflush, and if not no support + $<$>:$,USE_FFLUSH,NO_FLUSH_SUPPORT>> + $<$>:NO_GAMMA_SUPPORT> + + #!TODO Leaving as is in WRF for now but investigate why we don't do this + # https://stackoverflow.com/a/1035713 + # If fseeko64 succeeds, use that, else check if we can fall back to fseeko, and if not just use fseek + $,FSEEKO64_OK,$,FSEEKO_OK,FSEEK_OK>> + + # I don't believe these are used anymore... + # $<$:MPI2_SUPPORT=$> + # $<$:MPI2_THREAD_SUPPORT=$> + + ) + + +# Make core target +add_library( + ${PROJECT_NAME}_Core + STATIC + ) + +# Supplemental to core, or rather should be, some stuff in external is legitimately part of WRF and others +# are source code from truly external repositories - albeit old versions +add_subdirectory( external ) +add_subdirectory( tools ) + +# add_dependencies() does not support generator expressions so whatever we can defer to linking please do so +add_dependencies( + ${PROJECT_NAME}_Core + # So many things depend on this that I'm adding a dep here + registry_code + ) +target_include_directories( + ${PROJECT_NAME}_Core + PUBLIC + # List module directories first so the compiler does not get confused + # about things "not being compiled yet" - yes, yes it is compiled + # These are already set up to be @ install location + $ + $ + $ + $ + $ + $ + + $ + + + $ + $ + $ + $ + + $ + $ + + # For install interface includes, i.e. when used by external tools + # such as WPS + # $ + $ + $ + $ + + # May or may not exist + $<$:$> + $<$:$> + $<$:$> + $<$:$> + $<$:$> + $<$:$> + $<$:$> + $<$:$> + $<$:$> + + PRIVATE + + ${PROJECT_SOURCE_DIR}/dyn_em + + # externals + ${PROJECT_SOURCE_DIR}/external/esmf_time_f90 + ${PROJECT_SOURCE_DIR}/external/io_grib_share + ${PROJECT_SOURCE_DIR}/external/io_netcdf + ${PROJECT_SOURCE_DIR}/external/io_int + + # Found Packages not handled through :: imported target + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} + ${pnetCDF_INCLUDE_DIRS} + ) + +# Add directly to core +add_subdirectory( phys ) +add_subdirectory( share ) +add_subdirectory( frame ) +add_subdirectory( inc ) + +if ( ${WRF_CHEM} ) + add_subdirectory( chem ) +endif() + +if ( ${ENABLE_HYDRO} ) + add_subdirectory( hydro ) +endif() + +add_subdirectory( dyn_em ) + + +add_subdirectory( main ) + +################################################################################ +# Add subdirectory with case info +################################################################################ +if ( ${CURRENT_WRF_CORE_IDX} GREATER_EQUAL ${START_DA_IDX} ) + message( STATUS "DA or PLUS build, WRF_CASE selection ignored" ) +else() + add_subdirectory( test/${WRF_CASE_FOLDER} ) +endif() + +# Configure core +set_target_properties( + ${PROJECT_NAME}_Core + PROPERTIES + # Just dump everything in here + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/modules/ + Fortran_FORMAT FREE + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + +# Because of the way netCDF provides its info and the way cmake auto-gens RPATH, we need to help it along +target_link_directories( + ${PROJECT_NAME}_Core + PUBLIC + ${netCDF_LIBRARY_DIR} + ${netCDF-Fortran_LIBRARY_DIR} + ) + + +target_link_libraries( ${PROJECT_NAME}_Core + PUBLIC + ${netCDF_LIBRARIES} + ${netCDF-Fortran_LIBRARIES} + ${pnetCDF_LIBRARIES} + $<$:$> + $<$:$> + # This will add in target dependencies if they exist + $ + $ + $ + $ + $ + PRIVATE + + + # "External" io libs + esmf_time_f90 + + io_grib1 + grib1_util + MEL_grib1 + WGRIB + + io_grib_share + fftpack5 + + $ + $ + $ + $ + $ + io_int + io_netcdf + $ + $ + $ + + $ + $ + + $ + ) + +################################################################################ +## +## Install and export +## +################################################################################ +set( CONFIG_INSTALL_DIRECTORY lib/cmake/${PROJECT_NAME} ) +install( + TARGETS ${PROJECT_NAME}_Core + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) + +# Install to namespace +install( + EXPORT ${EXPORT_NAME}Targets + DESTINATION ${CONFIG_INSTALL_DIRECTORY} + FILE ${EXPORT_NAME}Targets.cmake + NAMESPACE ${EXPORT_NAME}:: + ) + +configure_package_config_file( + ${PROJECT_SOURCE_DIR}/cmake/template/${EXPORT_NAME}Config.cmake.in + ${CMAKE_BINARY_DIR}/${EXPORT_NAME}Config.cmake + INSTALL_DESTINATION ${CONFIG_INSTALL_DIRECTORY} + ) + +write_basic_package_version_file( + ${CMAKE_BINARY_DIR}/${EXPORT_NAME}ConfigVersion.cmake + VERSION ${PROJECT_VERSION} + #!TODO Check if this is the type of versioning support we want to use + COMPATIBILITY SameMinorVersion + ) + +install( + FILES + ${CMAKE_BINARY_DIR}/${EXPORT_NAME}Config.cmake + ${CMAKE_BINARY_DIR}/${EXPORT_NAME}ConfigVersion.cmake + DESTINATION ${CONFIG_INSTALL_DIRECTORY} + ) + +# Install some helper files for anyone using this build as part of their code +install( + DIRECTORY + # Trailing / is important + ${PROJECT_SOURCE_DIR}/cmake/modules/ + COMPONENT helpers + DESTINATION share + FILES_MATCHING + PATTERN "*.cmake" + ) +install( + FILES + ${PROJECT_SOURCE_DIR}/cmake/confcheck.cmake + ${PROJECT_SOURCE_DIR}/cmake/gitinfo.cmake + ${PROJECT_SOURCE_DIR}/cmake/printOption.cmake + ${PROJECT_SOURCE_DIR}/cmake/wrf_get_version.cmake + COMPONENT helpers + DESTINATION share + ) diff --git a/Makefile b/Makefile index 775eb3c246..2bdff94d81 100644 --- a/Makefile +++ b/Makefile @@ -97,7 +97,7 @@ configcheck: echo "------------------------------------------------------------------------------" ; \ exit 21 ; \ fi - + framework_only : configcheck $(MAKE) MODULE_DIRS="$(ALL_MODULES)" ext @@ -154,7 +154,7 @@ wrfplus : configcheck @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` -all_wrfvar : +all_wrfvar : $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir if [ $(CRTM) -ne 0 ] ; then \ @@ -498,7 +498,7 @@ em_scm_xy : wrf ln -sf ../../run/LANDUSE.TBL . ; \ ln -sf ../../run/SOILPARM.TBL . ; \ ln -sf ../../run/VEGPARM.TBL . ; \ - ln -sf ../../run/RRTM_DATA . ) + ln -sf ../../run/RRTM_DATA . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ @@ -529,11 +529,11 @@ convert_em : framework_only ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" convert_em ) ; \ fi -# Link wrf.exe and wrf_SST_ESMF.exe into -# test/em_esmf_exp when ESMF_COUPLING is set. wrf.exe -# can be used for stand-alone testing in this case. -# wrf_SST_ESMF.exe is a coupled application. Note that make -# target $(SOLVER)_wrf_SST_ESMF builds wrf_SST_ESMF.exe. +# Link wrf.exe and wrf_SST_ESMF.exe into +# test/em_esmf_exp when ESMF_COUPLING is set. wrf.exe +# can be used for stand-alone testing in this case. +# wrf_SST_ESMF.exe is a coupled application. Note that make +# target $(SOLVER)_wrf_SST_ESMF builds wrf_SST_ESMF.exe. em_real : wrf @/bin/rm -f real.exe > /dev/null 2>&1 @/bin/rm -f tc.exe > /dev/null 2>&1 @@ -923,31 +923,31 @@ framework : @ echo '--------------------------------------' ( cd frame ; $(MAKE) $(J) LLIST="$(LINKLIST)" framework ; \ cd ../external/io_netcdf ; \ - $(MAKE) NETCDFPATH="$(NETCDFPATH)" \ + $(MAKE) NETCDFPATH="$(NETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(FC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \ cd ../io_netcdf ; \ - $(MAKE) NETCDFPATH="$(NETCDFPATH)" \ + $(MAKE) NETCDFPATH="$(NETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \ cd ../io_netcdfpar ; \ - $(NETCDFPAR_BUILD) $(MAKE) NETCDFPARPATH="$(NETCDFPATH)" \ + $(NETCDFPAR_BUILD) $(MAKE) NETCDFPARPATH="$(NETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(FC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \ cd ../io_netcdfpar ; \ - $(NETCDFPAR_BUILD) $(MAKE) NETCDFPARPATH="$(NETCDFPATH)" \ + $(NETCDFPAR_BUILD) $(MAKE) NETCDFPARPATH="$(NETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \ cd ../io_pio ; \ - echo SKIPPING PIO BUILD $(MAKE) NETCDFPATH="$(PNETCDFPATH)" \ + echo SKIPPING PIO BUILD $(MAKE) NETCDFPATH="$(PNETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ @@ -964,13 +964,13 @@ framework_plus : @ echo '--------------------------------------' ( cd frame ; $(MAKE) $(J) LLIST="$(MODLL)" framework ; \ cd ../external/io_netcdf ; \ - $(MAKE) NETCDFPATH="$(NETCDFPATH)" \ + $(MAKE) NETCDFPATH="$(NETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(FC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \ cd ../io_netcdf ; \ - $(MAKE) NETCDFPATH="$(NETCDFPATH)" \ + $(MAKE) NETCDFPATH="$(NETCDFPATH)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ @@ -1069,10 +1069,10 @@ fseek_test : # rule used by configure to test if this will compile with netcdf4 nc4_test: - if [ $(USENETCDFPAR) -eq 0 ] ; then \ - ( cd tools ; /bin/rm -f nc4_test.{exe,nc,o} ; $(SCC) -o nc4_test.exe nc4_test.c -I$(NETCDF)/include -L$(NETCDF)/lib -lnetcdf $(NETCDF4_DEP_LIB) ; cd .. ) ; \ + if [ -z "$(USENETCDFPAR)" ] || [ $(USENETCDFPAR) -eq 0 ] ; then \ + ( cd tools ; /bin/rm -f nc4_test.{exe,nc,o} ; $(SCC) -o nc4_test.exe nc4_test.c -I$(NETCDF_C)/include $(NETCDF4_DEP_LIB) ; cd .. ) ; \ else \ - ( cd tools ; /bin/rm -f nc4_test.{exe,nc,o} ; $(DM_CC) -o nc4_test.exe nc4_test.c -I$(NETCDF)/include -L$(NETCDF)/lib -lnetcdf $(NETCDF4_DEP_LIB) ; cd .. ) ; \ + ( cd tools ; /bin/rm -f nc4_test.{exe,nc,o} ; $(DM_CC) -o nc4_test.exe nc4_test.c -I$(NETCDF_C)/include $(NETCDF4_DEP_LIB) ; cd .. ) ; \ fi # rule used by configure to test if Fortran 2003 IEEE signaling is available @@ -1110,8 +1110,8 @@ toolsdir : # ( cd tools ; $(MAKE) CC_TOOLS="$(CC_TOOLS) -DIO_MASK_SIZE=$(IO_MASK_SIZE)" ) -# Use this target to build stand-alone tests of esmf_time_f90. -# Only touches external/esmf_time_f90/. +# Use this target to build stand-alone tests of esmf_time_f90. +# Only touches external/esmf_time_f90/. esmf_time_f90_only : @ echo '--------------------------------------' ( cd external/esmf_time_f90 ; $(MAKE) FC="$(FC) $(FCFLAGS)" CPP="$(CPP) -DTIME_F90_ONLY" tests ) diff --git a/README b/README index 18c13efec1..a2135597d7 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -WRF Model Version 4.5.1 +WRF Model Version 4.6.0 https://www2.mmm.ucar.edu/wrf/users/ @@ -29,6 +29,7 @@ This is the main directory for the WRF Version 4 source code release. ====================================== Other README files are located in the WRF/doc directory: +doc/README.cmake_build doc/README.crtm doc/README.CTSM doc/README.cygwin.md diff --git a/Registry/Registry.EM_COMMON b/Registry/Registry.EM_COMMON index 889a92854b..76f485293d 100644 --- a/Registry/Registry.EM_COMMON +++ b/Registry/Registry.EM_COMMON @@ -98,6 +98,7 @@ state real sct_dom_gc ij dyn_em 1 - i1 "SCT_DOM" state real scb_dom_gc ij dyn_em 1 - i1 "SCB_DOM" "Dominant soil (bottom) category from GEOGRID" "cat" state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" + state real lai12m imj dyn_em 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" state real pdrho_gc igj dyn_em 1 Z - "PDRHO" "dry pressure for UM data for the variables U and V" "Pa" @@ -543,6 +544,12 @@ state real qvolg ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" state real qvolh ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" +state real qzr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QZRAIN" "Sixth moment rain" "m(6) kg(-1)" +state real qzg ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QZGRAUPEL" "Sixth moment graupel" "m(6) kg(-1)" +state real qzh ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QZHAIL" "Sixth moment hail" "m(6) kg(-1)" state real qrimef ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QRIMEF" "rime factor * qi" "kg kg-1" state real qir ikjftb scalar 1 - \ @@ -591,6 +598,12 @@ state real dfi_qnn ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qzr ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QZRAIN" "DFI Rain Reflectivity" "m(6) kg(-1)" +state real dfi_qzg ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QZGRAUPEL" "DFI Graupel Reflectivity" "m(6) kg(-1)" +state real dfi_qzh ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QZHAIL" "DFI Hail Reflectivity" "m(6) kg(-1)" state real dfi_qvolg ikjftb dfi_scalar 1 - \ rhusdf=(bdy_interp:dt) "DFI_QVGRAUPEL" "DFI Graupel Particle Volume" "m(3) kg(-1)" state real dfi_qvolh ikjftb dfi_scalar 1 - \ @@ -754,6 +767,7 @@ state real slope ij misc 1 - rdu "SLOP state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" state real shdmax ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" state real shdmin ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real shdavg ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SHDAVG" "ANNUAL AVG VEG FRACTION" "" state real snoalb ij misc 1 - i012rhd "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" state real landusef iuj misc 1 Z i012rdu "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" @@ -807,13 +821,18 @@ state real DZR l em - Z r "DZR" state real DZB l em - Z r "DZB" "THICKNESSES OF WALL LAYERS" "m" state real DZG l em - Z r "DZG" "THICKNESSES OF ROAD LAYERS" "m" state real URB_PARAM i{urb}j misc 1 - i1 "URB_PARAM" "NUDAPT_NBSD Urban Parameters" "parameter" -state real LP_URB2D ij misc 1 - ir "BUILD_AREA_FRACTION" "BUILDING PLAN AREA DENSITY" "dimensionless" +state real LP_URB2D ij misc 1 - i01r "BUILD_AREA_FRACTION" "BUILDING PLAN AREA DENSITY" "dimensionless" state real HI_URB2D i{uhi}j misc 1 Z ir "HEIGHT_HISTOGRAMS" "DISTRIBUTION OF BUILDING HEIGHTS" "dimensionless" state real LB_URB2D ij misc 1 - ir "BUILD_SURF_RATIO" "BUILDING SURFACE AREA TO PLAN AREA RATIO" "dimensionless" state real HGT_URB2D ij misc 1 - ir "BUILD_HEIGHT" "AVERAGE BUILDING HEIGHT WEIGHTED BY BUILDING PLAN AREA" "m" -state real MH_URB2D ij misc 1 - ir "MH_URB2D" "Mean Building Height" "m" +state real MH_URB2D ij misc 1 - i01r "MH_URB2D" "Mean Building Height" "m" state real STDH_URB2D ij misc 1 - ir "STDH_URB2D" "Standard Deviation of Building Height" "m2" state real LF_URB2D i{udr}j misc 1 Z ir "LF_URB2D" "Frontal Area Index" "dimensionless" +state real ZD_URB2D ij misc 1 - i1 "ZD_URB2D" "Zero-plane Displacement" "m" +state real Z0_URB2D ij misc 1 - i01r "Z0_URB2D" "Roughness length for momentum" "m" +state real LF_URB2D_S ij misc 1 - i01r "LF_URB2D_S" "Frontal area index (no wind directional dependency)" "" +# AHE with month and hour dimension flattened to one dimension, Jan = (0:23), Feb = (24:47) +state real AHE i{m_hr}j misc 1 - i01r "AHE" "Anthropogenic heat emission" "W m-2" # lsm State Variables @@ -1123,9 +1142,10 @@ state real sub_thl3D ikj misc 1 - h "s state real sub_sqv3D ikj misc 1 - h "sub_sqv3D" "qv subsidence tendency from EDMF" "kg kg-1 s-1" state real det_thl3D ikj misc 1 - h "det_thl3D" "thetaL detrainment tendency from EDMF" "K s-1" state real det_sqv3D ikj misc 1 - h "det_sqv3D" "qv detrainment tendency from EDMF" "kg kg-1 s-1" -state integer nupdraft ij misc 1 - h "nupdraft" "Number of updrafts per grid cell" "" state integer ktop_plume ij misc 1 - h "ktop_plume" "k-level of highest pentrating plume" "" state real maxMF ij misc 1 - h "maxMF" "Maximum mass-flux (neg: all dry, pos: moist)" "m/s * area" +state real maxwidth ij misc 1 - h "maxwidth" "Maximum plume width" "m" +state real ztop_plume ij misc 1 - h "ztop_plume" "Height of tallest plume" "m" #FogDES variables state real fgdp ij misc 1 - - "fgdp" "Accumulated fog deposition" "mm" @@ -2282,6 +2302,7 @@ rconfig integer interp_method_type namelist,domains 1 2 rconfig logical aggregate_lu namelist,domains 1 .false. irh "aggregate_lu" "T/F aggregate the grass, shrubs, trees in LU" rconfig logical rh2qv_wrt_liquid namelist,domains 1 .true. irh "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice" rconfig integer rh2qv_method namelist,domains 1 1 irh "rh2qv_method" "1=old MM5 method, 2=new WMO method" +rconfig logical use_sh_qv namelist,domains 1 .false. irh "use_sh_qv" "T/F whether to use SH or mixing ratio in input" rconfig real qv_max_p_safe namelist,domains 1 10000 irh "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value" "Pa" rconfig real qv_max_flag namelist,domains 1 1.E-5 irh "qv_max_flag" "Qv flag for max" "kg kg{-1}" rconfig real qv_max_value namelist,domains 1 3.E-6 irh "qv_max_value" "Qv value for max" "kg kg{-1}" @@ -2384,16 +2405,27 @@ rconfig logical write_thompson_tables namelist,physics 1 .tru rconfig logical write_thompson_mp38table namelist,physics 1 .false. rconfig integer mp_physics namelist,physics max_domains -1 irh "mp_physics" "" "" #rconfig integer milbrandt_ccntype namelist,physics max_domains 0 rh "milbrandt select maritime(1)/continental(2)" "" "" -rconfig real nssl_cccn namelist,physics max_domains 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" -rconfig real nssl_alphah namelist,physics max_domains 0 rh "Graupel PSD shape paramter" "" "" -rconfig real nssl_alphahl namelist,physics max_domains 1 rh "Hail PSD shape paramter" "" "" -rconfig real nssl_cnoh namelist,physics max_domains 4.e5 rh "Graupel intercept paramter" "" "" -rconfig real nssl_cnohl namelist,physics max_domains 4.e4 rh "Hail intercept paramter" "" "" -rconfig real nssl_cnor namelist,physics max_domains 8.e5 rh "Rain intercept paramter" "" "" -rconfig real nssl_cnos namelist,physics max_domains 3.e6 rh "Snow intercept paramter" "" "" -rconfig real nssl_rho_qh namelist,physics max_domains 500. rh "Graupel particle density" "" "" -rconfig real nssl_rho_qhl namelist,physics max_domains 900. rh "Hail particle density" "" "" -rconfig real nssl_rho_qs namelist,physics max_domains 100. rh "Snow particle density" "" "" +rconfig real nssl_cccn namelist,physics 1 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" +rconfig real nssl_alphah namelist,physics 1 0 rh "Graupel PSD shape paramter" "" "" +rconfig real nssl_alphahl namelist,physics 1 1 rh "Hail PSD shape paramter" "" "" +rconfig real nssl_cnoh namelist,physics 1 4.e5 rh "Graupel intercept paramter" "" "" +rconfig real nssl_cnohl namelist,physics 1 4.e4 rh "Hail intercept paramter" "" "" +rconfig real nssl_cnor namelist,physics 1 8.e5 rh "Rain intercept paramter" "" "" +rconfig real nssl_cnos namelist,physics 1 3.e6 rh "Snow intercept paramter" "" "" +rconfig real nssl_rho_qh namelist,physics 1 500. rh "Graupel particle density" "" "" +rconfig real nssl_rho_qhl namelist,physics 1 900. rh "Hail particle density" "" "" +rconfig real nssl_rho_qs namelist,physics 1 100. rh "Snow particle density" "" "" +rconfig integer nssl_icdx namelist,physics 1 6 rh "NSSL Graupel fall speed option" "" "" +rconfig integer nssl_icdxhl namelist,physics 1 6 rh "NSSL Hail fall speed option" "" "" +rconfig integer nssl_hail_on namelist,physics max_domains -1 rh "NSSL Hail flag" "" "" +rconfig integer nssl_ccn_on namelist,physics 1 -1 rh "NSSL CCN flag" "" "" +rconfig integer nssl_ccn_is_ccna namelist,physics 1 0 rh "NSSL flag that CCN is CCNA" "" "" +rconfig integer nssl_2moment_on namelist,physics 1 -1 rh "NSSL 2-moment flag" "" "" +rconfig integer nssl_3moment namelist,physics 1 0 rh "NSSL 3-moment flag" "" "" +rconfig integer nssl_density_on namelist,physics 1 -1 rh "NSSL graupel/hail density flag" "" "" + + + rconfig integer CCNTY namelist,physics 1 2 rh "Aerosol background type for NTU microphysics" "" "" # Lightning Qv Nudging @@ -2515,8 +2547,11 @@ rconfig integer ishallow namelist,physics 1 0 rconfig real convtrans_avglen_m namelist,physics 1 30 rh "convtrans_avglen_m" "averaging time for convective transport output variables (minutes)" "" rconfig integer num_land_cat namelist,physics 1 21 - "num_land_cat" "" "" rconfig integer use_wudapt_lcz namelist,physics 1 0 - "use_wudapt_lcz" "" "" +rconfig logical slucm_distributed_drag namelist,physics 1 .false. rh "slucm_distributed_drag" "" "" +rconfig integer distributed_ahe_opt namelist,physics 1 0 rh "distributed_ahe_opt" "AHE handling: 0= no AHE, 1=add to first level temperature tendency, 2=add to surface sensible heat flux" "" rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" +rconfig integer mp_zero_out_all namelist,physics 1 0 - "mp_zero_out_all" "1= if mp_zero_out>0, then reproduce old behavior of also applying to scalar/chem/tracer" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig logical bmj_rad_feedback namelist,physics max_domains .false. - "if true include radiative effects of bmj clouds" "" @@ -2994,11 +3029,8 @@ package cammgmpscheme mp_physics==11 - moist:qv,qc package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs;state:rimi package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow -package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow -package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg -package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg -package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow +# Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now +package nssl_2mom mp_physics==18 - moist:qv,qc,qr,qi,qs,qg package wsm7scheme mp_physics==24 - moist:qv,qc,qr,qi,qs,qg,qh;state:re_cloud,re_ice,re_snow package wdm7scheme mp_physics==26 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa,qnbca;state:re_cloud,re_ice,re_snow,qnwfa2d,qnifa2d,taod5503d,taod5502d @@ -3014,6 +3046,16 @@ package etampnew mp_physics==95 - moist:qv,qc package gsfcgcescheme mp_physics==97 - moist:qv,qc,qr,qi,qs,qg package madwrf_mp mp_physics==96 - moist:qv,qc,qi,qs +package nssl2mconc nssl_2moment_on==1 - scalar:qndrop,qnr,qni,qns,qng;state:re_cloud,re_ice,re_snow +package nssl3mg nssl_3moment==1 - scalar:qzr,qzg +package nssl3m nssl_3moment==2 - scalar:qzr,qzg,qzh +package nssl_hail nssl_hail_on==1 - moist:qh;scalar:qnh +package nssl_hail1m nssl_hail_on==2 - moist:qh; +package nssl_ccn_opt nssl_ccn_on==1 - scalar:qnn +package nssl_graupelvol nssl_density_on==1 - scalar:qvolg +package nssl_hailvol nssl_density_on==2 - scalar:qvolg,qvolh + + package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max endif @@ -3037,10 +3079,12 @@ package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi #package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg -package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +#package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +#package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package nssl_2mom_dfi mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +#package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg +#package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +#package nssl_2momg_dfi mp_physics_dfi==22 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wsm7scheme_dfi mp_physics_dfi==24 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wdm7scheme_dfi mp_physics_dfi==26 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa,dfi_qnbca;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow @@ -3092,7 +3136,7 @@ package temfsfcscheme sf_sfclay_physics==10 - state:wm_ package idealscmsfcscheme sf_sfclay_physics==89 - - package sfclayscheme sf_sfclay_physics==91 - - -package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,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,mh_urb2d,stdh_urb2d,lf_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,tgr_urb2d,cmcr_urb2d,drelr_urb2d,drelb_urb2d,drelg_urb2d,flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d,tgrl_urb3d,smr_urb3d,cmgr_sfcdif,chgr_sfcdif,trl_urb3d,tgl_urb3d,tbl_urb3d +package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,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,mh_urb2d,stdh_urb2d,lf_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,tgr_urb2d,cmcr_urb2d,drelr_urb2d,drelb_urb2d,drelg_urb2d,flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d,tgrl_urb3d,smr_urb3d,cmgr_sfcdif,chgr_sfcdif,trl_urb3d,tgl_urb3d,tbl_urb3d,ahe,lf_urb2d_s,z0_urb2d,zd_urb2d package bepscheme sf_urban_physics==2 - state: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,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,hi_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,trl_urb3d,tgl_urb3d,tbl_urb3d,tsk_rural package bep_bemscheme sf_urban_physics==3 - state: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,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,hi_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,trl_urb3d,tgl_urb3d,tbl_urb3d,tsk_rural,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 @@ -3133,7 +3177,7 @@ package kepsscheme bl_pbl_physics==17 - scalar:tke_ad package mrfscheme bl_pbl_physics==99 - - package tkebudget tke_budget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke -package mynn_dmp_edmf bl_mynn_edmf==1 - state:ktop_plume,maxmf,nupdraft +package mynn_dmp_edmf bl_mynn_edmf==1 - state:ktop_plume,ztop_plume,maxmf,maxwidth package mynn_3Doutput bl_mynn_output==1 - state:edmf_a,edmf_w,edmf_thl,edmf_qt,edmf_ent,edmf_qc,sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D package pbl_cloud icloud_bl==1 - state:cldfra_bl,qc_bl,qi_bl @@ -3336,6 +3380,8 @@ package wrfhydro wrf_hydro==1 - state:SOLDRAIN #WRF Windfarm package no_windfarm windfarm_opt==0 - - package fitchscheme windfarm_opt==1 - state:power +# Yulong add for WLM +package mavscheme windfarm_opt==2 - state:power #Ideal Cases package realcase ideal_case==0 - - @@ -3601,3 +3647,10 @@ xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy package no_fft_used fft_used==0 - - package any_fft_used fft_used==1 - state:t_xxx,u_xxx,ru_xxx,v_xxx,rv_xxx,w_xxx,ww_xxx,ph_xxx,dum_yyy,fourd_xxx +# Yulong add for wind wake models +# 1 = Jensen; 2 = XA; 3 = GM +rconfig integer windfarm_wake_model namelist,physics max_domains 2 rh "windfarm_wake_model" "" "" +# +# wake overlap method, M1, M2, M3, M4 [1, 2, 3, 4] +rconfig integer windfarm_overlap_method namelist,physics max_domains 4 rh "windfarm_overlap_method" "" "" +rconfig real windfarm_deg namelist,physics max_domains 0 - "windfarm_deg" "for windfarm ideal case" "degree" diff --git a/Registry/registry.chem b/Registry/registry.chem index 70586eae72..6cd996156b 100644 --- a/Registry/registry.chem +++ b/Registry/registry.chem @@ -82,7 +82,7 @@ state real e_hcho i+jf emis_ant 1 Z i5r "E_H state real e_ald i+jf emis_ant 1 Z i5r "E_ALD" "EMISSIONS" "mol km^-2 hr^-1" state real e_ket i+jf emis_ant 1 Z i5r "E_KET" "EMISSIONS" "mol km^-2 hr^-1" state real e_ora2 i+jf emis_ant 1 Z i5r "E_ORA2" "EMISSIONS" "mol km^-2 hr^-1" -state real e_nh3 i+jf emis_ant 1 Z i5r "E_NH3" "EMISSIONS" "mol km^-2 hr^-1" +state real e_nh3 i+jf emis_ant 1 Z i5rh01 "E_NH3" "EMISSIONS" "mol km^-2 hr^-1" state real e_pm_25 i+jf emis_ant 1 Z i5r "E_PM_25" "EMISSIONS" "ug/m3 m/s" state real e_pm_10 i+jf emis_ant 1 Z i5r "E_PM_10" "EMISSIONS" "ug/m3 m/s" state real e_pm25i i+jf emis_ant 1 Z i5r "E_PM25I" "EMISSION RATE OF UNIDEN. PM2.5 MASS" "ug/m3 m/s" @@ -213,7 +213,7 @@ state real setvel_1 ij misc 1 - r "set state real setvel_2 ij misc 1 - r "setvel_2" "dust gravitational settling velocity for size 2" "m/s" state real setvel_3 ij misc 1 - r "setvel_3" "dust gravitational settling velocity for size 3" "m/s" state real setvel_4 ij misc 1 - r "setvel_4" "dust gravitational settling velocity for size 4" "m/s" -state real setvel_5 ij misc 1 - r "setvel_5" "effective gravitational settling velocity for total" "m/s" +state real setvel_5 ij misc 1 - r "setvel_5" "dust gravitational settling velocity for size 5" "m/s" state real dustgraset_1 ij misc 1 - r "graset_1" "Accumulated dust gravitational settling for size 1" "kg/m2" state real dustgraset_2 ij misc 1 - r "graset_2" "Accumulated dust gravitational settling for size 2" "kg/m2" state real dustgraset_3 ij misc 1 - r "graset_3" "Accumulated dust gravitational settling for size 3" "kg/m2" @@ -670,6 +670,17 @@ state real pftp_hb ij misc 1 - i06r "pft state real mtsa ijm misc 1 Z i06r "mtsa" "Monthly surface air temp" "K" state real mswdown ijm misc 1 Z i06r "mswdown" "Monthly SWdown" "W/m2" state real EFmegan ij{nm} misc 1 - - "EFmegan" "MEGAN2 Emis Factor" "ug m^-2 hr^-1" +# Arrays for online ammonia emissions +state real EFnh3 ij misc 1 - i01rh01 "EFNH3" "NH3 Emis Factor" "ug m^-2 hr^-1" +state real actnh3 imj misc 1 Z i01rh01d "ACTNH3" "The activity of NH3" "0 - 1 fraction" +state real agrisoil_nh3 ij misc 1 Z i01rh01d "AGRISOIL_NH3" "The activity of NH3" "0 - 1 fraction" +state real fertilizer_nh3 imj misc 1 Z i01rh01d "FERTILIZER_NH3" "The activity of NH3" "0 - 1 fraction" +state real freeinten_nh3 ij misc 1 Z i01rh01d "FREEINTEN_NH3" "The activity of NH3" "0 - 1 fraction" +state real graze_nh3 ij misc 1 Z i01rh01d "GRAZE_NH3" "The activity of NH3" "0 - 1 fraction" +state real industry_nh3 ij misc 1 Z i01rh01d "INDUSTRY_NH3" "The activity of NH3" "0 - 1 fraction" +state real residential_nh3 ij misc 1 Z i01rh01d "RESIDENTIAL_NH3" "The activity of NH3" "0 - 1 fraction" +state real transport_nh3 ij misc 1 Z i01rh01d "TRANSPORT_NH3" "The activity of NH3" "0 - 1 fraction" + # Input for GOCART: Background chemistry, erodible surface emissions map state real backg_oh ikj misc 1 - i08r "BACKG_OH" "Background OH for Aerosol-GOcart option" "volume mixing ratio" state real backg_h2o2 ikj misc 1 - i08r "BACKG_H2O2" "Background H2O2 for Aerosol-GOcart option" "volume mixing ratio" @@ -3832,6 +3843,10 @@ rconfig integer emiss_opt namelist,chem max_domains rconfig integer emiss_opt_vol namelist,chem max_domains 0 rh "emiss_opt_vol" "" "" rconfig integer dust_opt namelist,chem 1 0 rh "dust_opt" "" "" rconfig integer dust_schme namelist,chem 1 2 rh "dust_schme" "" "" + +#renchuanhua rch added +rconfig integer nh3emis_opt namelist,chem 1 0 rh "nh3emis_opt" "" "" + rconfig integer dmsemis_opt namelist,chem 1 0 rh "dmsemis_opt" "" "" rconfig integer seas_opt namelist,chem 1 0 rh "seas_opt" "" "" rconfig integer bio_emiss_opt namelist,chem max_domains 0 rh "bio_emiss_opt" "" "" @@ -3904,8 +3919,9 @@ rconfig integer mosaic_aerchem_optaa namelist,chem 1 rconfig real af_lambda_start namelist,chem max_domains 200. rh "start wavelength for AF output" "nm" "" rconfig real af_lambda_end namelist,chem max_domains 340. rh "end wavelength for AF output" "nm" "" # Control for ISORROPIA in MADE/SORGAM schemes + rconfig logical do_isorropia namelist,chem 1 .false. rh "flag to use ISORROPIA" -rconfig logical do_n2o5het namelsit,chem 1 .false. rh "flag to do n2o5 heterogenous chemistry via chlorine pathway" +rconfig logical do_n2o5het namelist,chem 1 .false. rh "flag to do n2o5 heterogenous chemistry via chlorine pathway" # CHEMISTRY PACKAGE DEFINITIONS # @@ -4085,6 +4101,10 @@ package beis314 bio_emiss_opt==2 - - package megan2 bio_emiss_opt==3 - state:mebio_isop,mebio_apin,mebio_bcar,mebio_acet,mebio_mbo,mebio_no,msebio_isop,mlai,pftp_bt,pftp_nt,pftp_sb,pftp_hb,mtsa,mswdown,EFmegan package megan2_clm bio_emiss_opt==4 +# renchuanhua rch added for online nh3 emissions +package offline nh3emis_opt==0 - - +package online nh3emis_opt==1 - state:EFnh3,agrisoil_nh3,fertilizer_nh3,freeinten_nh3,graze_nh3,industry_nh3,residential_nh3,transport_nh3;emis_ant:e_nh3 + # Biospheric CO2 and CH4 emissions package ebioco2 bio_emiss_opt==16 - state:rad_vprm,lambda_vprm,alpha_vprm,resp_vprm;vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;eghg_bio:ebio_gee,ebio_res,ebio_co2oce package ebioghg bio_emiss_opt==17 - state:rad_vprm,lambda_vprm,alpha_vprm,resp_vprm;vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;wet_in:cpool,wetmap,t_ann;eghg_bio:ebio_gee,ebio_res,ebio_co2oce,ebio_ch4wet,ebio_ch4soil,ebio_ch4term diff --git a/Registry/registry.dimspec b/Registry/registry.dimspec index 041bb2fefa..6761de8f7b 100644 --- a/Registry/registry.dimspec +++ b/Registry/registry.dimspec @@ -140,3 +140,5 @@ endif # Dimensions for PSU-DENG SCP dimspec nsh 2 constant=100 z nsh +# Dimensions for AHE +dimspec m_hr 2 constant=(0:287) z month_hour diff --git a/Registry/registry.fire b/Registry/registry.fire index 35a2284c35..6d1b33eb0a 100644 --- a/Registry/registry.fire +++ b/Registry/registry.fire @@ -221,6 +221,17 @@ rconfig integer fire_sprd_mdl namelist,fire max_domains rconfig real fire_crwn_hgt namelist,fire max_domains 15. - "fire_crwn_hgt" "height that heat from crown fire is released" "m" rconfig real fire_ext_grnd namelist,fire max_domains 50. - "fire_ext_grnd" "extinction depth of sfc fire heat" "m" rconfig real fire_ext_crwn namelist,fire max_domains 50. - "fire_ext_crwn" "extinction depth of crown fire heat" "m" +# +# ------------------------------------------------------------------------------------------------------------------------ +# variable for Truncated Gaussian dist. +# +rconfig integer fire_sfc_flx namelist,fire max_domains 0 - "fire_sfc_flx" "compute flux div according to 0=exponential decay, 1=Truncated Gaussian distribution" "" +rconfig real fire_heat_peak namelist,fire max_domains 0. - "fire_heat_peak" "ONLY fire_sfc_flx=1, the peak heat release height for the Truncated Gaussian scheme" "m AGL" +rconfig real fire_tg_ub namelist,fire max_domains 1000. - "fire_tg_ub" "The upper bpund of the Truncated Gaussian scheme; the default typically works well" "m AGL" +rconfig integer fire_smk_scheme namelist,fire max_domains 0 - "fire_smk_scheme" "Fire smoke release scheme; 0=tracers at first level, 1=Truncated Gaussian dist" +rconfig real fire_smk_peak namelist,fire max_domains 0. - "fire_smk_peak" "ONLY fire_smk_scheme=1, the peak smoke release height for the Truncated Gaussian scheme" "m AGL" +rconfig real fire_smk_ext namelist,fire max_domains 50. - "fire_smk_ext" "ONLY fire_smk_scheme=1, the extinction depth of smoke" "m AGL" + rconfig real fire_wind_height namelist,fire max_domains 6.096 - "fire_wind_height" "height of uah,vah wind in fire spread formula" "m" rconfig integer fire_fuel_read namelist,fire max_domains -1 - "fire_fuel_read" "fuel categories are set by: if 0, uniform; if 1, user-presc; if 2, read from file" "" rconfig integer fire_fuel_cat namelist,fire max_domains 1 - "fire_fuel_cat" "fuel category if ifuelread=0" "" diff --git a/Registry/registry.var b/Registry/registry.var index e3c6c9cfa3..32cc1471db 100644 --- a/Registry/registry.var +++ b/Registry/registry.var @@ -170,12 +170,19 @@ rconfig logical use_radar_rv namelist,wrfvar4 1 .false. - "rad rconfig logical use_radar_rf namelist,wrfvar4 1 .false. - "reflectivity" "" "" rconfig logical use_radar_rqv namelist,wrfvar4 1 .false. - "retrieved water vapor" "" "" rconfig logical use_radar_rhv namelist,wrfvar4 1 .false. - "retr. hydrometeor var" "" "" +rconfig integer radar_rhv_opt namelist,wrfvar4 1 1 - "hydrometeor retrieval option" "2 is for background-dependent scheme" "" rconfig integer radar_rf_opt namelist,wrfvar4 1 1 - "reflectivity DA option" "" "" rconfig real rf_qthres namelist,wrfvar4 1 1e-12 - "mixing ratio threshold" "" "" rconfig real rfmin namelist,wrfvar4 1 0.0 - "min rf for no-rain echo" "" "" rconfig integer rf_noice namelist,wrfvar4 1 0 - "disable ice phace in H" "" "" rconfig real radar_rf_rscl namelist,wrfvar4 1 1.0 - "weight of rf" "" "" rconfig real radar_rv_rscl namelist,wrfvar4 1 1.0 - "weight of rv" "" "" +rconfig logical use_lightningobs namelist,wrfvar4 1 .false. - "use_lightningobs" "" "" +rconfig logical use_lightning_w namelist,wrfvar4 1 .false. - "use_lightning_w" "" "" +rconfig logical use_lightning_qv namelist,wrfvar4 1 .false. - "use_lightning_qv" "" "" +rconfig logical use_lightning_div namelist,wrfvar4 1 .false. - "use_lightning_div" "" "" +rconfig real min_flashrate namelist,wrfvar4 1 2.0 - "min_flashrate" "" "" +rconfig real lightning_min_rh namelist,wrfvar4 1 85. - "lightning_min_rh" "" "" rconfig logical use_rainobs namelist,wrfvar4 1 .false. - "use_rainobs" "" "" rconfig logical use_hirs2obs namelist,wrfvar4 1 .false. - "use_hirs2obs" "" "" rconfig logical use_hirs3obs namelist,wrfvar4 1 .false. - "use_hirs3obs" "" "" @@ -195,6 +202,7 @@ rconfig logical use_amsr2obs namelist,wrfvar4 1 .false. - "use rconfig logical use_ahiobs namelist,wrfvar4 1 .false. - "use_ahiobs" "" "" rconfig logical use_gmiobs namelist,wrfvar4 1 .false. - "use_gmiobs" "" "" rconfig logical use_goesimgobs namelist,wrfvar4 1 .false. - "use_goesimgobs" "" "" +rconfig logical use_goesabiobs namelist,wrfvar4 1 .false. - "use_goesabiobs" "" "" rconfig logical use_kma1dvar namelist,wrfvar4 1 .false. - "use_kma1dvar" "" "" rconfig logical use_filtered_rad namelist,wrfvar4 1 .false. - "use_filtered_rad" "" "" rconfig logical use_obs_errfac namelist,wrfvar4 1 .false. - "use_obs_errfac" "" "" @@ -229,6 +237,9 @@ rconfig real max_error_buv namelist,wrfvar5 1 500.0 - "max rconfig real max_error_bt namelist,wrfvar5 1 500.0 - "max_error_bt" "" "" rconfig real max_error_bq namelist,wrfvar5 1 500.0 - "max_error_bq" "" "" rconfig real max_error_slp namelist,wrfvar5 1 500.0 - "max_error_slp" "" "" +rconfig real max_error_lda_w namelist,wrfvar5 1 5.0 - "max_error_lda_w" "" "" +rconfig real max_error_lda_div namelist,wrfvar5 1 5.0 - "max_error_lda_div" "" "" +rconfig real max_error_lda_qv namelist,wrfvar5 1 5.0 - "max_error_lda_qv" "" "" rconfig logical check_buddy namelist,wrfvar5 1 .false. - "check_buddy" "" "" rconfig logical put_rand_seed namelist,wrfvar5 1 .false. - "put_rand_seed" "" "" rconfig logical omb_set_rand namelist,wrfvar5 1 .false. - "omb_set_rand" "" "" @@ -458,6 +469,7 @@ rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "va rconfig integer use_clddet namelist,wrfvar14 1 2 - "use_clddet" "0: off, 1: mmr, 2: pf, 3: ecmwf" "" rconfig logical use_clddet_zz namelist,wrfvar14 1 .false. - "use_clddet_zz" "cloud detection scheme from Zhuge X. and Zou X. JAMC, 2016." "" rconfig integer ahi_superob_halfwidth namelist,wrfvar14 1 0 - "ahi_superob_halfwidth" "" "" +rconfig integer abi_superob_halfwidth namelist,wrfvar14 1 0 - "abi_superob_halfwidth" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" rconfig logical use_blacklist_rad namelist,wrfvar14 1 .true. - "use_blacklist_rad" "" "" @@ -467,6 +479,7 @@ rconfig character crtm_irwater_coef namelist,wrfvar14 1 "Nalli.IRwater rconfig character crtm_mwwater_coef namelist,wrfvar14 1 "FASTEM5.MWwater.EmisCoeff.bin" - "crtm_mwwater_coef" "" "" rconfig character crtm_irland_coef namelist,wrfvar14 1 "USGS.IRland.EmisCoeff.bin" - "crtm_irland_coef" "" "" rconfig character crtm_visland_coef namelist,wrfvar14 1 "USGS.VISland.EmisCoeff.bin" - "crtm_visland_coef" "" "" +rconfig logical abi_use_symm_obs_err namelist,wrfvar14 1 .false. - "abi_use_symm_obs_err" "" "" rconfig logical ahi_use_symm_obs_err namelist,wrfvar14 1 .false. - "ahi_use_symm_obs_err" "" "" rconfig logical ahi_apply_clrsky_bias namelist,wrfvar14 1 .false. - "ahi_apply_clrsky_bias" "" "" rconfig integer num_pseudo namelist,wrfvar15 1 0 - "num_pseudo" "" "" @@ -580,11 +593,8 @@ package cammgmpscheme mp_physics==11 - moist:qv,qc package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh -package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh -package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh -package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg -package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg +# Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now +package nssl_2mom mp_physics==18 - moist:qv,qc,qr,qi,qs,qg package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg package p3_1category mp_physics==50 - moist:qv,qc,qr,qi package p3_1category_nc mp_physics==51 - moist:qv,qc,qr,qi @@ -594,6 +604,7 @@ package ntu mp_physics==56 - moist:qv,qc package etampnew mp_physics==95 - moist:qv,qc,qr,qs package lscondscheme mp_physics==98 - moist:qv package mkesslerscheme mp_physics==99 - moist:qv,qc,qr + # package mpnotset_4dvar mp_physics_4dvar==-1 - g_moist:g_qv;a_moist:a_qv package passiveqv_4dvar mp_physics_4dvar==0 - g_moist:g_qv;a_moist:a_qv @@ -613,11 +624,8 @@ package cammgmp_4dvar mp_physics_4dvar==11 - g_moist:g_q package sbu_ylin_4dvar mp_physics_4dvar==13 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm5_4dvar mp_physics_4dvar==14 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm6_4dvar mp_physics_4dvar==16 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2mom_4dvar mp_physics_4dvar==17 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_2momccn_4dvar mp_physics_4dvar==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1mom_4dvar mp_physics_4dvar==19 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1momlfo_4dvar mp_physics_4dvar==21 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2momg_4dvar mp_physics_4dvar==22 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg +# Note: Options 17, 19, 21, 22 are deprecated but still reserved for compatibility -- for now +package nssl_2mom_4dvar mp_physics_4dvar==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh package thompsonaero_4dvar mp_physics_4dvar==28 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package p3_1category_4dvar mp_physics_4dvar==50 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi package p3_1category_nc_4dvar mp_physics_4dvar==51 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi diff --git a/Registry/registry.wrfplus b/Registry/registry.wrfplus index 7f277a882d..2b6f933c47 100644 --- a/Registry/registry.wrfplus +++ b/Registry/registry.wrfplus @@ -872,11 +872,7 @@ package cammgmp_plus mp_physics_plus==11 - g_moist:g_qv, package sbu_ylin_plus mp_physics_plus==13 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm5_plus mp_physics_plus==14 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs package wdm6_plus mp_physics_plus==16 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2mom_plus mp_physics_plus==17 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_2momccn_plus mp_physics_plus==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1mom_plus mp_physics_plus==19 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh -package nssl_1momlfo_plus mp_physics_plus==21 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package nssl_2momg_plus mp_physics_plus==22 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg +package nssl_2mom_plus mp_physics_plus==18 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh package thompsonaero_plus mp_physics_plus==28 - g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package p3_1category_plus mp_physics_plus==50 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi package p3_1category_nc_plus mp_physics_plus==51 - g_moist:g_qv,g_qc,g_qr,g_qi;a_moist:a_qv,a_qc,a_qr,a_qi diff --git a/arch/Config.pl b/arch/Config.pl index 9585dfd3a1..761c540abe 100644 --- a/arch/Config.pl +++ b/arch/Config.pl @@ -49,8 +49,9 @@ $sw_time = "" ; # name of a timer to time fortran compiles, e.g. timex or time $sw_ifort_r8 = 0 ; $sw_hdf5 = "-lhdf5_hl -lhdf5"; +$sw_hdf5_hl_fortran="-lhdf5_hl_fortran"; $sw_zlib = "-lz"; -$sw_dep_lib_path = ""; +$sw_netcdf4_dep_lib = ""; $sw_gpfs_path = ""; $sw_gpfs_lib = "-lgpfs"; $sw_curl_path = ""; @@ -69,10 +70,10 @@ { $sw_netcdf_path = substr( $ARGV[0], 8 ) ; } - if ( substr( $ARGV[0], 1, 13 ) eq "dep_lib_path=" ) + if ( substr( $ARGV[0], 1, 16 ) eq "netcdf4_dep_lib=" ) { - $sw_dep_lib_path = substr( $ARGV[0], 14 ) ; - $sw_dep_lib_path =~ s/\r|\n/ /g ; + $sw_netcdf4_dep_lib = substr( $ARGV[0], 17 ) ; + $sw_netcdf4_dep_lib =~ s/\r|\n/ /g ; } if ( substr( $ARGV[0], 1, 5 ) eq "gpfs=" ) { @@ -349,6 +350,15 @@ $sw_ctsm_mkfile_path = $ENV{WRF_CTSM_MKFILE}; } +if ( $sw_hdf5_path ) { + opendir(my $dh, "$sw_hdf5_path/lib"); + ($hl) = grep(/hdf5hl_fortran/i, readdir $dh); + closedir($dh); + if ($hl ne "") { + $sw_hdf5_hl_fortran="-lhdf5hl_fortran"; + } +} + # parse the configure.wrf file $validresponse = 0 ; @@ -453,6 +463,7 @@ } else { $sw_terrain_and_landuse =" -DLANDREAD_STUB=1" ; } + open CONFIGURE_DEFAULTS, "cat ./arch/configure.defaults |" ; $latchon = 0 ; while ( ) @@ -732,7 +743,7 @@ } if ( $sw_hdf5_path ) - { $_ =~ s:CONFIGURE_HDF5_LIB_PATH:-L$sw_hdf5_path/lib -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -lm -lz: ; + { $_ =~ s:CONFIGURE_HDF5_LIB_PATH:-L$sw_hdf5_path/lib $sw_hdf5_hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -lm -lz: ; $_ =~ s:CONFIGURE_HDF5_FLAG:-DHDF5: ; } else @@ -1039,7 +1050,7 @@ $_ =~ s/CONFIGURE_CONFIG_NUM/Compiler choice: $response_opt/g ; $_ =~ s/CONFIGURE_CONFIG_NEST/Nesting option: $response_nesting/g ; - $_ =~ s/CONFIGURE_DEP_LIB_PATH/$sw_dep_lib_path/g ; + $_ =~ s/CONFIGURE_NETCDF4_DEP_LIB/$sw_netcdf4_dep_lib/g ; $_ =~ s/CONFIGURE_COMMS_LIB/$sw_comms_lib/g ; if ( $sw_os ne "CYGWIN_NT" ) { @@ -1120,7 +1131,7 @@ } if ( $sw_hdf5_path ) - { $_ =~ s:CONFIGURE_HDF5_LIB_PATH:-L$sw_hdf5_path/lib -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -lm -lz: ; + { $_ =~ s:CONFIGURE_HDF5_LIB_PATH:-L$sw_hdf5_path/lib $sw_hdf5_hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -lm -lz: ; $_ =~ s:CONFIGURE_HDF5_FLAG:-DHDF5: ; } else @@ -1169,7 +1180,7 @@ $_ .= " " . $sw_curl_lib . "\n" ; } } - if ( $sw_dep_lib_path ne "" ) + if ( $sw_netcdf4_dep_lib ne "" ) { if (/^HDF5.*=/) { $_ =~ s/\r|\n//g; $_ .= " " . $sw_hdf5 . "\n" ; @@ -1200,4 +1211,3 @@ printf "Configuration successful! \n" ; printf "------------------------------------------------------------------------\n" ; - diff --git a/arch/configure.defaults b/arch/configure.defaults index aed98042a2..1275f3ce33 100644 --- a/arch/configure.defaults +++ b/arch/configure.defaults @@ -304,7 +304,7 @@ DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -350,7 +350,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): Xeon Phi (MIC architecture) DMPARALLEL = 1 OMPCPP = -D_OPENMP OMP = -qopenmp -fpp -auto -OMPCC = -qopenmp -fpp -auto +OMPCC = -qopenmp SFC = ifort -mmic SCC = icc -mmic CCOMP = icc -mmic @@ -398,7 +398,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): Xeon (SNB with AVX mods) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -472,7 +472,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): SGI MPT DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -522,7 +522,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): IBM POE DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -602,7 +602,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): ia64 DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -686,7 +686,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): SGI Altix DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -818,7 +818,7 @@ CC_TOOLS = $(SCC) NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) PGI compiler with pgcc #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) PGI compiler with pgcc #serial smpar dmpar dm+sm # DESCRIPTION = PGI ($SFC/$SCC) DMPARALLEL = # 1 @@ -862,13 +862,13 @@ CC_TOOLS = cc NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) intel compiler with icc #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) intel compiler with icc #serial smpar dmpar dm+sm # DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -909,7 +909,7 @@ CC_TOOLS = cc NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) intel compiler with clang EDIT FOR OPENMPI #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) intel compiler with clang EDIT FOR OPENMPI #serial smpar dmpar dm+sm # DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 @@ -955,7 +955,7 @@ CC_TOOLS = cc NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) g95 with gcc #serial dmpar +#ARCH Darwin x86_64 arm64, (MACOS) g95 with gcc #serial dmpar # DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 @@ -1000,7 +1000,7 @@ CC_TOOLS = $(SCC) NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) gfortran with gcc #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) gfortran with gcc #serial smpar dmpar dm+sm # DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 @@ -1045,7 +1045,7 @@ CC_TOOLS = $(SCC) NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) gfortran with clang #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) gfortran with clang #serial smpar dmpar dm+sm # DESCRIPTION = GNU ($SFC/clang) DMPARALLEL = # 1 @@ -1090,7 +1090,7 @@ CC_TOOLS = clang NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) xlf #serial dmpar +#ARCH Darwin x86_64 arm64, (MACOS) xlf #serial dmpar # DESCRIPTION = IBM ($SFC/$SCC) DMPARALLEL = # 1 @@ -1358,7 +1358,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): Cray XC DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ftn SCC = icc CCOMP = icc @@ -1695,7 +1695,7 @@ CC_TOOLS = $(SCC) NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) PGI compiler with pgcc -f90= #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) PGI compiler with pgcc -f90= #serial smpar dmpar dm+sm # DESCRIPTION = PGI ($SFC/$SCC): -f90=pgf90 DMPARALLEL = # 1 @@ -1739,13 +1739,13 @@ CC_TOOLS = cc NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) intel compiler with icc #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) intel compiler with icc #serial smpar dmpar dm+sm # DESCRIPTION = INTEL ($SFC/$SCC): Open MPI DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -1786,7 +1786,7 @@ CC_TOOLS = cc NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD ########################################################### -#ARCH Darwin (MACOS) gfortran with gcc openmpi #serial smpar dmpar dm+sm +#ARCH Darwin x86_64 arm64, (MACOS) gfortran with gcc openmpi #serial smpar dmpar dm+sm # DESCRIPTION = GNU ($SFC/$SCC): Open MPI DMPARALLEL = # 1 @@ -1881,7 +1881,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): HSW/BDW DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -1926,7 +1926,7 @@ DESCRIPTION = INTEL ($SFC/$SCC): KNL MIC DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -qopenmp -fpp -auto -OMPCC = # -qopenmp -fpp -auto +OMPCC = # -qopenmp SFC = ifort SCC = icc CCOMP = icc @@ -2124,6 +2124,92 @@ NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD #insert new stanza here +########################################################### +#ARCH Linux x86_64 ppc64le i486 i586 i686, Intel oneAPI compiler with icx #serial smpar dmpar dm+sm +# This mirrors the above Intel build but changes ifort=>ifx icc=>icx + +DESCRIPTION = INTEL ($SFC/$SCC) : oneAPI LLVM +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -qopenmp -fpp -auto +OMPCC = # -qopenmp -auto +SFC = ifx +SCC = icx +CCOMP = icx +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=$(SCC) +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC CONFIGURE_D_CTSM +CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars # -DRSL0_ONLY +LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 -fno-inline -no-ip +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u +FORMAT_FIXED = -FI +FORMAT_FREE = -FR +FCSUFFIX = +BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl +FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS +AR = ar +ARFLAGS = ru +M4 = m4 +RANLIB = ranlib +RLFLAGS = +CC_TOOLS = $(SCC) +NETCDFPAR_BUILD = CONFIGURE_NETCDFPAR_BUILD + +########################################################### +#ARCH Linux aarch64, armclang compiler OpenMPI # serial smpar dmpar dm+sm +# +DESCRIPTION = armclang ($SFC/$SCC): Aarch64 +DMPARALLEL = +OMPCPP = -fopenmp +OMP = -fopenmp +OMPCC = -fopenmp +SFC = armflang +SCC = armclang +CCOMP = armclang +DM_FC = mpif90 +DM_CC = mpicc -DMPI2_SUPPORT +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = +ARCH_LOCAL = +CFLAGS_LOCAL = -w -O3 -c -Wno-implicit-function-declaration -Wno-int-conversion -Wno-implicit-int +LDFLAGS_LOCAL = -fopenmp +FCOPTIM = -Ofast -mcpu=native -funroll-loops +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 -fopenmp -frecursive +FCDEBUG = -g $(FCNOOPT) +FORMAT_FIXED = -ffixed-form -ffixed-line-length-0 +FORMAT_FREE = -ffree-form -ffree-line-length-0 +FCSUFFIX = +BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 +FCBASEOPTS = -w $(FORMAT_FREE) $(BYTESWAPIO) +MODULE_SRCH_FLAG= -I$(WRF_SRC_ROOT_DIR)/main +TRADFLAG = -traditional-cpp +CPP = /lib/cpp CONFIGURE_CPPFLAGS +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +RLFLAGS = +CC_TOOLS = $(SCC) -Wno-implicit-function-declaration -Wno-int-conversion -Wno-implicit-int + ########################################################### #ARCH Linux aarch64, GCC compiler OpenMPI # serial smpar dmpar dm+sm # diff --git a/arch/configure_reader.py b/arch/configure_reader.py new file mode 100755 index 0000000000..fb89bfca80 --- /dev/null +++ b/arch/configure_reader.py @@ -0,0 +1,628 @@ +#!/usr/bin/env python3 + +import argparse +import sys +import os +import re +import inspect +import platform +from shutil import which + +archBlock = re.compile( r"(?:#[ ]*)(ARCH(?:.*\n)*?)(?:#{5,})", re.I ) +kvPair = re.compile( r"^(\w+)(?:[ \t]*=[ \t]*)(.*?)$", re.I | re.M ) +# Make this gnarly and complicated since configure.defaults has no standard formatting +# v start v OS V typical v MACOS +osAndArch = re.compile( r"^ARCH[ ]+(\w+)[ ]+((?:\w+.*?),|(?:[(].*?[)]))", re.I ) +# Just grab the first two words, thats what you get +osAndArchAlt = re.compile( r"^ARCH[ ]+(\w+)[ ]+(\w+)", re.I ) + +referenceVar = re.compile( r"[$]([(])?(\w+)(?(1)[)])", re.I ) +compileObject = re.compile( r"(\W)-c(\W)" ) + +class Stanza(): + + def __init__( self, lines ) : + self.lines_ = lines + self.os_ = None + self.arch_ = None + self.osArchLine_ = None + self.archs_ = [] + self.kvPairs_ = {} + self.crossPlatform_ = False + self.skipCrossPlatform_ = True + self.serialOpt_ = False + self.smparOpt_ = False + self.dmparOpt_ = False + self.dmsmOpt_ = False + + def parse( self ) : + self.osArchLine_ = self.lines_.partition("\n")[0] + # First get os & archs + osarchMatch = osAndArch.match( self.osArchLine_ ) + + if osarchMatch is None : + osarchMatch = osAndArchAlt.match( self.osArchLine_ ) + if osarchMatch is None : + print( "Could not find OS and architecture info in " + self.osArchLine_ ) + + self.os_ = osarchMatch.group(1) + self.archs_ = osarchMatch.group(2).strip(",").split( " " ) + + if ( self.os_.lower() != platform.system().lower() or + platform.machine() not in self.archs_ ) : + self.crossPlatform_ = True + + # Allow cross platform or must not be cross platform + if not self.skipCrossPlatform_ or ( self.skipCrossPlatform_ and not self.crossPlatform_ ) : + + # Find OpenMP/MPI compilation options + memOpts = self.osArchLine_.partition( "#" )[-1].split( " " ) + # print( memOpts ) + self.serialOpt_ = "serial" in memOpts + self.smparOpt_ = "smpar" in memOpts + self.dmparOpt_ = "dmpar" in memOpts + self.dmsmOpt_ = "dm+sm" in memOpts + + for kvPairMatch in kvPair.finditer( self.lines_ ) : + self.kvPairs_[ kvPairMatch.group(1) ] = kvPairMatch.group(2) + self.removeComments( kvPairMatch.group(1) ) + + # Now sanitize + self.sanitize() + + ###################################################################################################################### + ## + ## search and replace $() and $ instances + ## + ###################################################################################################################### + def dereference( self, field, fatal=False ) : + # print( "Dereferencing " + field ) + + if field in self.kvPairs_ : + prevField = self.kvPairs_[field] + + for refVarIter in referenceVar.finditer( prevField ) : + envSub = None + + if refVarIter is not None : + # Grab group 1 and check that it is in our kv pairs + refVar = refVarIter.group(2) + # print( "Found variable {0} in field {1}".format( refVar, field ) ) + if refVar not in self.kvPairs_ : + # Try to use the environment variables + if refVar in os.environ : + envSub = os.environ[ refVar ] + else: + if fatal : + # print( "Could not rereference : " + refVar ) + exit(1) + else: + continue + + + # This is an environment variable + if envSub is not None : + self.kvPairs_[field] = self.kvPairs_[field].replace( + "{var}".format( var=refVarIter.group(0) ), + envSub + ) + # This is a kv pair, recurse + else : + # Recursively deref + self.dereference( refVar, fatal ) + + # Replace in original + self.kvPairs_[field] = self.kvPairs_[field].replace( + "{var}".format( var=refVarIter.group(0) ), + self.kvPairs_[refVar] + ) + + def removeReferences( self, field, specifics=[] ) : + if field in self.kvPairs_ : + if specifics : + for specific in specifics : + self.kvPairs_[ field ] = self.kvPairs_[ field ].replace( + "$({var})".format( var=specific ), + "" + ) + else : + self.kvPairs_[ field ] = referenceVar.sub( "", self.kvPairs_[ field ] ) + + + def removeComments( self, field ) : + if field in self.kvPairs_ : + self.kvPairs_[ field ] = self.kvPairs_[ field ].split( "#", 1 )[0] + + def splitIntoFieldAndFlags( self, field ) : + # Fix flags being mixed with programs + if field in self.kvPairs_ : + fieldValue = self.kvPairs_[ field ] + + self.kvPairs_[field] = fieldValue.partition(" ")[0] + self.kvPairs_[field + "_FLAGS"] = fieldValue.partition(" ")[1] + + ###################################################################################################################### + ## + ## Clean up the stanza so kv pairs can be used as-is + ## + ###################################################################################################################### + def sanitize( self ) : + # Fix problematic variables + self.dereference( "DM_FC" ) + self.dereference( "DM_CC" ) + self.removeReferences( "FCBASEOPTS_NO_G" ) + # Get rid of all these mixed up flags, these are handled by cmake natively or + # just in the wrong place + self.removeReferences( "FCBASEOPTS", [ "FCDEBUG", "FORMAT_FREE", "BYTESWAPIO", ] ) + self.removeReferences( "FFLAGS", [ "FORMAT_FREE", "FORMAT_FIXED" ] ) + self.removeReferences( "F77FLAGS", [ "FORMAT_FREE", "FORMAT_FIXED" ] ) + # # Now deref + self.dereference( "FCBASEOPTS" ) + + # Remove rogue compile commands that should *NOT* even be here + keysToSanitize = [ + "ARFLAGS","ARFLAGS", + "CC", + "CFLAGS_LOCAL", + "CFLAGS", + "COMPRESSION_INC", + "COMPRESSION_LIBS", + "CPP", + "CPPFLAGS", + "DM_CC", + "DM_FC", + "ESMF_LDFLAG", + "F77FLAGS", + "FC", + "FCBASEOPTS_NO_G", + "FCBASEOPTS", + "FCOPTIM", + "FCSUFFIX", + "FDEFS", + "FFLAGS", + "FNGFLAGS", + "FORMAT_FIXED", + "FORMAT_FREE", + "LD", + "LDFLAGS_LOCAL", + "LDFLAGS", + "MODULE_SRCH_FLAG", + "RLFLAGS", + "SCC", + "SFC", + "TRADFLAG", + ] + + for keyToSan in keysToSanitize : + if keyToSan in self.kvPairs_ : + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_COMP_L", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_COMP_I", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_FC", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_CC", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_FDEFS", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_MPI", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_COMPAT_FLAGS", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_CPPFLAGS", "" ) + self.kvPairs_[ keyToSan ] = self.kvPairs_[ keyToSan ].replace( "CONFIGURE_TRADFLAG", "" ) + + self.kvPairs_[ keyToSan ] = compileObject.sub( r"\1\2", self.kvPairs_[ keyToSan ] ).strip() + + + # Now fix certain ones that are mixing programs with flags all mashed into one option + self.splitIntoFieldAndFlags( "SFC" ) + self.splitIntoFieldAndFlags( "SCC" ) + self.splitIntoFieldAndFlags( "DM_FC" ) + self.splitIntoFieldAndFlags( "DM_CC" ) + self.splitIntoFieldAndFlags( "CPP" ) + self.splitIntoFieldAndFlags( "M4" ) + + # Now deref all the rest + for key in self.kvPairs_ : + self.dereference( key ) + # And for final measure strip + self.kvPairs_[ key ] = self.kvPairs_[ key ].strip() + + def serialCompilersAvailable( self ) : + return which( self.kvPairs_["SFC"] ) is not None and which( self.kvPairs_["SCC"] ) is not None + + def dmCompilersAvailable( self ) : + return which( self.kvPairs_["DM_FC"] ) is not None and which( self.kvPairs_["DM_CC"] ) is not None + + ###################################################################################################################### + ## + ## string representation to view as option + ## + ###################################################################################################################### + def __str__( self ): + # base = """OS {os:<8} ARCHITECTURES {archs:<20} + # >> SFC = {SFC:<12} + # >> SCC = {SCC:<12} + # >> CCOMP = {CCOMP:<12} + # >> DM_FC = {DM_FC:<12} + # >> DM_CC = {DM_CC:<12} + # """ + base = """ {os:<10} {recSFC} {SFC:<11} / {recSCC} {SCC:<11} / {recDM_FC} {DM_FC:<11} / {recDM_CC} {DM_CC:<11}""" + text = inspect.cleandoc( base ).format( + os=str(self.os_), + recSFC =( "!!" if which( self.kvPairs_["SFC"] ) is None else (" " * 2 ) ), + recSCC =( "!!" if which( self.kvPairs_["SCC"] ) is None else (" " * 2 ) ), + recDM_FC=( "!!" if which( self.kvPairs_["DM_FC"] ) is None else (" " * 2 ) ), + recDM_CC=( "!!" if which( self.kvPairs_["DM_CC"] ) is None else (" " * 2 ) ), + # archs=str(self.archs_), + SFC=str( self.kvPairs_["SFC"] ), + SCC=str( self.kvPairs_["SCC"] ), + DM_FC=str( self.kvPairs_["DM_FC"] ), + DM_CC=str( self.kvPairs_["DM_CC"] ) + ) + # text += "\n" + "\n".join( [ "{key:<18} = {value}".format( key=key, value=value) for key, value in self.kvPairs_.items() ] ) + return text + + ###################################################################################################################### + ## + ## Find first apparent difference between two stanzas + ## + ###################################################################################################################### + @staticmethod + def findFirstDifference( rhStanza, lhStanza, maxLength=32 ) : + diff = False + value = "" + valuesToCheck = [ + "ARCH_LOCAL", + "BYTESWAPIO", + "CFLAGS_LOCAL", + "CFLAGS", + "DM_CC_FLAGS", + "DM_CC", + "DM_FC_FLAGS", + "DM_FC", + "FCBASEOPTS", + "FCDEBUG", + "FCNOOPT", + "FCOPTIM", + "FFLAGS", + "M4_FLAGS", + "SCC", + "SFC" + ] + for rhKey, rhValue in rhStanza.kvPairs_.items() : + if rhKey in valuesToCheck and rhKey in lhStanza.kvPairs_ : + # Qualifies for difference + if rhValue != lhStanza.kvPairs_[rhKey] : + diff = True + value = "{key:<12} = {value}".format( key=rhKey, value=lhStanza.kvPairs_[rhKey] ) + + # Truncate + value = ( value[:maxLength] + "..." ) if len( value ) > maxLength else value + + return diff, value + +######################################################################################################################## +## +## Option handling +## +######################################################################################################################## +def getOptionsParser() : + parser = argparse.ArgumentParser( ) + + # https://stackoverflow.com/a/24181138 + requiredNamed = parser.add_argument_group( "required named arguments" ) + + requiredNamed.add_argument( + "-c", "--config", + dest="configFile", + help="configure.defaults file holding all stanza configurations", + type=str, + required=True + ) + requiredNamed.add_argument( + "-t", "--template", + dest="cmakeTemplateFile", + help="cmake template file for configuring stanza into cmake syntax", + type=str, + required=True + ) + requiredNamed.add_argument( + "-o", "--output", + dest="outputConfigFile", + help="cmake output toolchain config file for selected stanza", + type=str, + required=True + ) + + parser.add_argument( + "-p", "--preselect", + dest="preselect", + help="Use preselected stanza configuration, if multiple match grabs the first one", + type=str, + default=None + ) + + parser.add_argument( + "-x", "--skipCMakeOptions", + dest="skipCMakeOptions", + help="Skip query of available CMake options", + default=False, + const=True, + action='store_const' + ) + parser.add_argument( + "-s", "--source", + dest="sourceCMakeFile", + help="Required unless -x/--skipCMakeOptions set, project cmake source file used to determine available options", + type=str, + default=None + ) + + return parser + + +class Options(object): + """Empty namespace""" + pass + +######################################################################################################################## +## +## Select stanza to operate on +## +######################################################################################################################## +def selectStanza( options ) : + + fp = open( options.configFile, 'r' ) + lines = fp.read() + fp.close() + + # Now grab the blocks and parse + stanzas = [] + # Gather all stanzas available + for stanzaBlock in archBlock.finditer( lines ) : + stanza = Stanza( stanzaBlock.group(1) ) + stanza.parse() + + if not stanza.crossPlatform_ and stanza.serialCompilersAvailable() and ( stanza.dmCompilersAvailable() or ( stanza.serialOpt_ or stanza.smparOpt_ ) ) : + if "DESCRIPTION" not in stanza.kvPairs_ : + # Of course WPS configure.defaults is different than WRF so descriptions are embedded in the comments + stanza.kvPairs_[ "DESCRIPTION" ] = stanza.osArchLine_.partition( "," )[ -1 ].partition( "#" )[0].strip() + stanzas.append( stanza ) + + idxSelection = 0 + if options.preselect is None : + # Query for selected + stanzaIdx = 0 + uniqueConfigs = {} + for stanza in stanzas : + stanzaConfig = str( stanza ) + stanzaId = "{idx:<3} ".format( idx=stanzaIdx ) + if stanzaConfig not in uniqueConfigs : + uniqueConfigs[ stanzaConfig ] = { "stanza" : stanza, "idx" : stanzaIdx } + + print( stanzaId + stanzaConfig + stanza.kvPairs_[ "DESCRIPTION" ] ) + # else : + # diff, value = Stanza.findFirstDifference( uniqueConfigs[ stanzaConfig ]["stanza"], stanza ) + # if diff : + # print( stanzaId + stanzaConfig + "@{idx} diff => {value}".format( idx=uniqueConfigs[ stanzaConfig ][ "idx" ], value=value ) ) + # else : + # print( stanzaId + stanzaConfig + "[no difference]" ) + stanzaIdx += 1 + print( "!! - Compiler not found, some configurations will not work and will be hidden" ) + stringSelection = input( "Select configuration [0-{stop}] Default [0] (note !!) : ".format( stop=( stanzaIdx-1) ) ) + idxSelection = int( stringSelection if stringSelection.isdigit() else 0 ) + if idxSelection < 0 or idxSelection > stanzaIdx - 1 : + print( "Invalid configuration selection!" ) + exit(1) + else : + for stanza in stanzas : + if options.preselect.lower() in stanza.kvPairs_["DESCRIPTION"].lower() : + print( str( stanza ) + stanza.kvPairs_[ "DESCRIPTION"] ) + break + else : + idxSelection += 1 + if idxSelection == len( stanzas ) : + print( "Error: Stanza configuration with description '{0}' does not exist. Preselect failed.".format( options.preselect ) ) + exit(1) + + stanzaCfg = stanzas[idxSelection] + + return stanzaCfg + +######################################################################################################################## +## +## Select enum-like string for string-based cmake options +## +######################################################################################################################## +def getStringOptionSelection( topLevelCmake, searchString, destinationOption, defaultIndex=0 ) : + topLevelCmakeFP = open( topLevelCmake, "r" ) + topLevelCmakeLines = topLevelCmakeFP.read() + topLevelCmakeFP.close() + + stringOptionsMatch = re.search( + r"set\s*[(]\s*" + searchString + r"\s*(.*?)[)]", + topLevelCmakeLines, + re.I | re.S | re.M + ) + if stringOptionsMatch is None : + print( "Syntax error in parsing " + searchString + " from " + topLevelCmake ) + exit(1) + + options = [ option.split( "#", 1 )[0].strip() for option in stringOptionsMatch.group(1).split( "\n" ) ] + # Weed out empties + options = [ option for option in options if option ] + + optionsFmt = "\n\t" + "\n\t".join( [ "{idx} : {opt}".format( idx=options.index( opt ), opt=opt ) for opt in options ] ) + stringSelection = input( "Select option for {option} from {optionsSource} [0-{max}] {opts} \nDefault [{defIdx}] : ".format( + option=destinationOption, + optionsSource=searchString, + max=len(options)-1, + opts=optionsFmt, + defIdx=defaultIndex + ) + ) + selection = int( stringSelection if stringSelection.isdigit() else defaultIndex ) + + if selection < 0 or selection > len(options) : + print( "Invalid option selection for " + searchString + "!" ) + exit(1) + + return options[selection] + +######################################################################################################################## +## +## Aggregate and allow toggle of various suboptions in alternate menu +## +######################################################################################################################## +def getSubOptions( topLevelCmake, ignoreOptions ) : + topLevelCmakeFP = open( topLevelCmake, "r" ) + topLevelCmakeLines = topLevelCmakeFP.read() + topLevelCmakeFP.close() + + stringOptionsMatch = re.finditer( + r"set\s*[(]\s*(\w+)\s*(ON|OFF)\s*CACHE\s*BOOL\s*\"(.*?)\"\s*[)]", + topLevelCmakeLines, + re.I | re.M + ) + # Remove commented ones and ones that don't follow pattern set( ON|OFF CACHE BOOL "" ) + options = [ [ option.group( 1 ), option.group( 2 ) ] for option in stringOptionsMatch if option.group( 1 ) == option.group( 3 ) and option.group(0).split( "#", 1 )[0].strip() ] + + # Remove ignore options + options = [ option for option in options if option[0] not in ignoreOptions ] + subOptions = {} + + if options : + subOptionQuit = False + optionToggleIdx = -1 + + # Print menu + optionStr = "{idx:<3} {option:<24} : {value:<5}" + print( optionStr.format( idx="ID", option="Option", value="Default" ) ) + for opt in options : + print( optionStr.format( idx=options.index(opt), option=opt[0], value=opt[1] ) ) + + print( "Enter ID to toggle option on or off, q to quit : " ) + # Loop until q, toggle from default not current value + while not subOptionQuit : + optionToggleIdx = input() + try: + optionToggleIdx = int( optionToggleIdx ) + if optionToggleIdx < 0 or optionToggleIdx >= len( options ) : + print( "Not a valid index" ) + else: + subOptions[ options[optionToggleIdx][0] ] = "ON" if not ( options[optionToggleIdx][1] == "ON" ) else "OFF" + print( "Set {option} to {value}".format( option=options[optionToggleIdx][0], value=subOptions[ options[optionToggleIdx][0] ] ) ) + except ValueError as err : + subOptionQuit = optionToggleIdx.lower() == "q" + + return subOptions + +def main() : + + parser = getOptionsParser() + options = Options() + parser.parse_args( namespace=options ) + + stanzaCfg = selectStanza( options ) + + additionalOptions = {} + if not options.skipCMakeOptions : + if options.sourceCMakeFile is None : + print( "Error: Project source cmake file required for project specific options." ) + exit(1) + else: + additionalOptions = projectSpecificOptions( options, stanzaCfg ) + + generateCMakeToolChainFile( options.cmakeTemplateFile, options.outputConfigFile, stanzaCfg, additionalOptions ) + +######################################################################################################################## +######################################################################################################################## +## +## ABOVE THIS BREAK THINGS ARE EXACTLY THE SAME AS WRF/WPS +## BELOW THIS BREAK THINGS DIFFER +## +######################################################################################################################## +######################################################################################################################## + +def generateCMakeToolChainFile( cmakeToolChainTemplate, output, stanza, optionsDict={} ) : + cmakeToolChainTemplateFP = open( cmakeToolChainTemplate, "r" ) + cmakeToolChainTemplateLines = cmakeToolChainTemplateFP.read() + cmakeToolChainTemplateFP.close() + + configStanza = cmakeToolChainTemplateLines.format( + ARCH_LOCAL=stanza.kvPairs_["ARCH_LOCAL"], + BYTESWAPIO=stanza.kvPairs_["BYTESWAPIO"], + CFLAGS_LOCAL=stanza.kvPairs_["CFLAGS_LOCAL"], + DM_CC=stanza.kvPairs_["DM_CC"], + DM_FC=stanza.kvPairs_["DM_FC"], + DM_FC_FLAGS=stanza.kvPairs_["DM_FC_FLAGS"], + DM_CC_FLAGS=stanza.kvPairs_["DM_CC_FLAGS"], + FCBASEOPTS=stanza.kvPairs_["FCBASEOPTS"], + FCDEBUG=stanza.kvPairs_["FCDEBUG"], + FCNOOPT=stanza.kvPairs_["FCNOOPT"], + FCOPTIM=stanza.kvPairs_["FCOPTIM"], + M4_FLAGS=stanza.kvPairs_["M4_FLAGS"], + SCC=stanza.kvPairs_["SCC"], + SFC=stanza.kvPairs_["SFC"], + SCC_FLAGS=stanza.kvPairs_["SCC_FLAGS"], + SFC_FLAGS=stanza.kvPairs_["SFC_FLAGS"], + CPP=stanza.kvPairs_["CPP"], + CPP_FLAGS=stanza.kvPairs_["CPP_FLAGS"], + ) + + # Extra stufff not from stanza but options + fmtOption = "set( {opt:<32} {value:<12} CACHE STRING \"Set by configuration\" FORCE )" + configStanza += "\n" + "\n".join( [ fmtOption.format( opt=key, value=value ) for key, value in optionsDict.items() ] ) + + outputFP = open( output, "w" ) + outputFP.write( configStanza ) + outputFP.close() + +def projectSpecificOptions( options, stanzaCfg ) : + coreOption = getStringOptionSelection( options.sourceCMakeFile, "WRF_CORE_OPTIONS", "WRF_CORE" ) + nestingOption = getStringOptionSelection( options.sourceCMakeFile, "WRF_NESTING_OPTIONS", "WRF_NESTING", 1 ) + caseOption = getStringOptionSelection( options.sourceCMakeFile, "WRF_CASE_OPTIONS", "WRF_CASE" ) + + # These are yes + yesValues = [ "yes", "y", "true", "1" ] + # Acceptable no values + noValues = [ "no", "n", "false", "0" ] + + ############################################################################## + # Decompose the weird way to write the logic for DM/SM + USE_MPI = False + if ( stanzaCfg.serialOpt_ or stanzaCfg.smparOpt_ ) and ( stanzaCfg.dmparOpt_ or stanzaCfg.dmsmOpt_ ) : + # togglable + # we can safely check this since the user would not have been able to select this stanza if it couldn't be disabled + if stanzaCfg.dmCompilersAvailable() : + useMPI = not( input( "[DM] Use MPI? Default [Y] [Y/n] : " ).lower() in noValues ) + else : + useMPI = False + else: + # User has no choice in the matter + useMPI = ( stanzaCfg.dmparOpt_ or stanzaCfg.dmsmOpt_ ) + + useOpenMP = False + if ( stanzaCfg.serialOpt_ or stanzaCfg.dmparOpt_ ) and ( stanzaCfg.smparOpt_ or stanzaCfg.dmsmOpt_ ): + # togglable + useOpenMP = input( "[SM] Use OpenMP? Default [N] [y/N] : " ).lower() in yesValues + else: + # User has no choice in the matter + useOpenMP = ( stanzaCfg.smparOpt_ or stanzaCfg.dmsmOpt_ ) + + ############################################################################## + + alreadyAsked = [ "USE_MPI", "USE_OPENMP" ] + doSuboptionMenu = input( "Configure additional options? Default [N] [y/N] : " ).lower() in yesValues + subOptions = {} + if doSuboptionMenu : + subOptions = getSubOptions( options.sourceCMakeFile, alreadyAsked ) + + additionalOptions = { + "WRF_CORE" : coreOption, + "WRF_NESTING" : nestingOption, + "WRF_CASE" : caseOption, + "USE_MPI" : "ON" if useMPI else "OFF", + "USE_OPENMP" : "ON" if useOpenMP else "OFF", + } + additionalOptions.update( subOptions ) + + return additionalOptions + +if __name__ == '__main__' : + main() \ No newline at end of file diff --git a/arch/postamble b/arch/postamble index 061fb4e0da..aa55662073 100644 --- a/arch/postamble +++ b/arch/postamble @@ -94,15 +94,16 @@ module_dm_rsllite : ( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; \ cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F ; fi ) -wrfio_nf : +wrfio_nf : ( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \ make $(J) NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ - CC="$(SCC)" CFLAGS="$(CFLAGS)" \ + CC="$(SCC)" CFLAGS="$(CFLAGS)" NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(SFC) $(PROMOTION) $(OMP) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) wrfio_nfpar : ( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdfpar ; \ make $(J) NETCDFPARPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCHFLAGS)" \ + NETCDF4_DEP_LIB="$(NETCDF4_DEP_LIB)" \ FC="$(FC) $(PROMOTION) $(OMP) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) wrfio_pnf : @@ -118,7 +119,7 @@ wrfio_adios2 : wrfio_grib_share : ( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \ make $(J) CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ - FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) + FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) wrfio_grib1 : ( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \ @@ -132,13 +133,13 @@ wrfio_grib2 : FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \ FIXED="$(FORMAT_FIXED)" archive) -wrfio_int : +wrfio_int : ( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \ make $(J) CC="$(CC)" CFLAGS_LOCAL="$(CFLAGS_LOCAL)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(OMP)" FGREP="$(FGREP)" \ TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ARCHFLAGS="$(ARCHFLAGS)" all ) -esmf_time : +esmf_time : ( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \ make $(J) FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) @@ -201,12 +202,26 @@ wrfio_esmf : mv $*.f90.tmp $*.f90 ; \ fi $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 - + +.F90.o: + $(RM) $@ + sed -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F90 > $*.G + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.G > $*.bb + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 + $(RM) $*.G $*.bb + $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 .F.f90: $(RM) $@ sed -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F > $*.G - $(SED_FTN) $*.G > $*.H + $(SED_FTN) $*.G > $*.H + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.H > $@ + $(RM) $*.G $*.H + +.F90.f90: + $(RM) $@ + sed -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F90 > $*.G + $(SED_FTN) $*.G > $*.H $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.H > $@ $(RM) $*.G $*.H diff --git a/arch/preamble b/arch/preamble index ab97abbb4b..4ae897d496 100644 --- a/arch/preamble +++ b/arch/preamble @@ -17,7 +17,7 @@ SHELL = /bin/sh DEVTOP = `pwd` LIBINCLUDE = . -.SUFFIXES: .F .i .o .f90 .c +.SUFFIXES: .F .i .o .f90 .c .F90 #### Get core settings from environment (set in compile script) #### Note to add a core, this has to be added to. @@ -94,8 +94,7 @@ GPFS = CURL = HDF5 = ZLIB = -DEP_LIB_PATH = CONFIGURE_DEP_LIB_PATH -NETCDF4_DEP_LIB = $(DEP_LIB_PATH) $(HDF5) $(ZLIB) $(GPFS) $(CURL) +NETCDF4_DEP_LIB = CONFIGURE_NETCDF4_DEP_LIB # NETCDF4INCLUDEGOESHERE diff --git a/chem/CMakeLists.txt b/chem/CMakeLists.txt new file mode 100644 index 0000000000..9bfbf3d5ac --- /dev/null +++ b/chem/CMakeLists.txt @@ -0,0 +1,226 @@ +# WRF CMake Build +target_include_directories( + ${PROJECT_NAME}_Core + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +######################################################################################################################## +# +# Now add sources +# +######################################################################################################################## +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + module_data_isrpia_data.F + module_data_ISRPIA.F + module_data_isrpia_asrc.F + module_data_isrpia_solut.F + module_data_isrpia_kmc198.F + module_data_isrpia_kmc223.F + module_data_isrpia_kmc248.F + module_data_isrpia_kmc273.F + module_data_isrpia_kmc298.F + module_data_isrpia_kmc323.F + module_data_isrpia_expnc.F + module_data_isrpia_caseg.F + module_data_isrpia_casej.F + isofwd.F + isorev.F + isocom.F + moduleHETDATA.F + moduleHETAERO.F + moduleAERODATA.F + aerorate_so2.F + module_aer_opt_out.F + module_add_emiss_burn.F + module_add_emis_cptec.F + module_bioemi_beis314.F + module_chem_utilities.F + module_cmu_dvode_solver.F + module_data_cbmz.F + module_data_cmu_bulkaqchem.F + module_data_gocartchem.F + module_data_gocart_seas.F + module_data_mosaic_kind.F + module_data_mosaic_constants.F + module_data_mosaic_aero.F + module_data_mosaic_main.F + module_data_mosaic_asect.F + module_data_mosaic_asecthp.F + module_data_mosaic_boxmod.F + module_data_mosaic_other.F + module_data_mosaic_therm.F + module_data_radm2.F + module_data_rrtmgaeropt.F + module_data_megan2.F + module_data_soa_vbs.F + module_data_soa_vbs_het.F + module_data_sorgam.F + module_data_sorgam_vbs.F + module_ftuv_subs.F + module_ghg_fluxes.F + module_gocart_drydep.F + module_gocart_settling.F + module_gocart_so2so4.F + module_input_tracer_data.F + module_interpolate.F + module_mosaic_csuesat.F + module_mozcart_wetscav.F + module_peg_util.F + module_tropopause.F + module_upper_bc_driver.F + module_vertmx_wrf.F + module_wave_data.F + module_wetdep_ls.F + module_zero_plumegen_coms.F + module_vash_settling.F + module_chem_plumerise_scalar.F + module_dep_simple.F + module_gocart_dmsemis.F + module_gocart_aerosols.F + module_gocart_dust.F + module_gocart_dust_afwa.F + module_gocart_seasalt.F + module_uoc_dust.F + module_qf03.F + module_soilpsd.F + module_dust_load.F + module_uoc_dustwd.F + module_data_uoc_wd.F + module_mosaic_addemiss.F + module_mosaic_initmixrats.F + module_mosaic_support.F + module_mosaic_init_aerpar.F + module_mosaic_ext.F + module_mosaic_astem.F + module_mosaic_lsode.F + module_mosaic_box_aerchem.F + module_mosaic_aerchem_intr.F + module_mosaic_coag1d.F + module_mosaic_coag3d.F + module_mosaic_movesect1d.F + module_mosaic_movesect3d.F + module_mosaic_newnucb.F + module_mosaic_sect_intr.F + module_mosaic_aerdynam_intr.F + module_mosaic_movesect.F + module_mosaic_newnuc.F + module_mosaic_soa_vbs.F + module_cbmz_lsodes_solver.F + module_cbmz_rodas3_solver.F + module_cmu_bulkaqchem.F + module_data_mgn2mech.F + module_ftuv_driver.F + module_fastj_data.F + module_fastj_mie.F + module_input_chem_data.F + module_mosaic_coag.F + module_mosaic_gly.F + module_mosaic_wetscav.F + module_mosaic_therm.F + module_phot_mad.F + params.mod.F #!TODO Rename this please + numer.F + rdxs.F + rxn.F + params_mod.F + module_phot_tuv.F + module_subs_tuv.F + rtrans.F + la_srb.F + module_radm.F + module_sorgam_aqchem.F + module_sorgam_vbs_aqchem.F + module_aerosols_soa_vbs.F + module_aerosols_soa_vbs_het.F + module_aerosols_sorgam.F + module_aerosols_sorgam_vbs.F + module_bioemi_megan2.F + module_bioemi_simple.F + module_cbm4_initmixrats.F + module_cb05_initmixrats.F + module_cb05_vbs_initmixrats.F + module_cbmz.F + module_cbmz_initmixrats.F + module_cbmz_rodas_prep.F + module_ctrans_grell.F + module_gocart_chem.F + module_input_tracer.F + module_lightning_nox_driver.F + module_lightning_nox_ott.F + module_lightning_nox_decaria.F + module_mixactivate_wrappers.F + module_mosaic_init_aerpar.F + module_mosaic2_driver.F + module_mosaic_sumpm.F + module_mosaic_driver.F + module_optical_averaging.F + module_plumerise1.F + module_mosaic_drydep.F + module_wetscav_driver.F + module_prep_wetscav_sorgam.F + module_input_chem_bioemiss.F + module_input_dust_errosion.F + module_input_gocart_dms.F + module_cbmz_addemiss.F + module_cbm4_addemiss.F + module_cb05_addemiss.F + module_emissions_anthropogenics.F + module_aer_drydep.F + module_cam_mam_calcsize.F + module_cam_mam_dust_sediment.F + module_cam_mam_drydep.F + module_cam_mam_init.F + module_cam_mam_initaerodata.F + module_cam_mam_initmixrats.F + module_cam_mam_rename.F + module_cam_mam_wateruptake.F + module_cam_mam_gasaerexch.F + module_cam_mam_coag.F + module_cam_mam_newnuc.F + module_cam_mam_aerchem_driver.F + module_cam_mam_addemiss.F + module_cam_mam_wetscav.F + module_cam_mam_mz_aerosols_intr.F + module_cam_mam_wetdep.F + module_cam_mam_cloudchem.F + module_cam_mam_setsox.F + module_cam_mam_mo_chem_utls.F + module_mosaic_cloudchem.F + module_sorgam_cloudchem.F + module_sorgam_vbs_cloudchem.F + module_cam_mam_gas_wetdep_driver.F + module_cam_mam_mo_sethet.F + module_phot_fastj.F + module_chem_cup.F + module_isocom.F + module_isofwd.F + module_isorev.F + chemics_init.F + chem_driver.F + cloudchem_driver.F + photolysis_driver.F + optical_driver.F + mechanism_driver.F + emissions_driver.F + dry_dep_driver.F + aerosol_driver.F + ) + +######################################################################################################################## +# +# convert_emiss executable +# +######################################################################################################################## +add_executable( + convert_emiss + convert_emiss.F + ) + +target_link_libraries( + convert_emiss + PRIVATE + ${PROJECT_NAME}_Core + ) \ No newline at end of file diff --git a/chem/KPP/configure_kpp b/chem/KPP/configure_kpp index d2fe9259a9..a1b8a346b8 100755 --- a/chem/KPP/configure_kpp +++ b/chem/KPP/configure_kpp @@ -80,14 +80,17 @@ echo " configure_kpp, settings:" if test -e "${FLEX_LIB_DIR}/libfl.a" ; then echo location of flex library: ${FLEX_LIB_DIR}/libfl.a +elif test -e "${FLEX_LIB_DIR}/libfl.so" ; then +echo location of flex library: ${FLEX_LIB_DIR}/libfl.so + else - echo No libfl.a in ${FLEX_LIB_DIR} + echo No libfl.a or libfl.so in ${FLEX_LIB_DIR} echo ' check if FLEX_LIB_DIR environment variable is set correctly' - echo ' (FLEX_LIB_DIR should be the complete pathname of the FLEX library libfl.a)' + echo ' (FLEX_LIB_DIR should be the complete pathname of the FLEX library libfl.a or libfl.so)' echo ' OR: Enter full path to flex library on your system' read FLEX_LIB_DIR - if test ! -e ${FLEX_LIB_DIR}/libfl.a ; then - echo PROBLEM: libfl.a NOT FOUND IN ${FLEX_LIB_DIR} + if test ! -e ${FLEX_LIB_DIR}/libfl.a && test ! -e ${FLEX_LIB_DIR}/libfl.so ; then + echo PROBLEM: libfl.a or libfl.so NOT FOUND IN ${FLEX_LIB_DIR} read FLEX_LIB_DIR fi diff --git a/chem/KPP/kpp/kpp-2.1/src/code.c b/chem/KPP/kpp/kpp-2.1/src/code.c index a628eabb5a..cc3ca9684a 100755 --- a/chem/KPP/kpp/kpp-2.1/src/code.c +++ b/chem/KPP/kpp/kpp-2.1/src/code.c @@ -32,6 +32,7 @@ #include "gdata.h" #include "code.h" +#include "scan.h" #include #include #include @@ -98,7 +99,6 @@ FILE * mex_jacFile = 0; FILE * mex_hessFile = 0; FILE * wrf_UpdateRconstFile = 0; - FILE * currentFile; int ident = 0; @@ -193,7 +193,7 @@ char *p; p = outBuf; while( *p ) *p++ &= ~0x80; - fprintf( currentFile, outBuf ); + fprintf( currentFile, "%s", outBuf ); outBuffer = outBuf; *outBuffer = 0; } @@ -205,7 +205,7 @@ char *p; p = buf; while( *p ) *p++ &= ~0x80; - fprintf( currentFile, buf ); + fprintf( currentFile, "%s", buf ); } void WriteDelim() diff --git a/chem/KPP/kpp/kpp-2.1/src/code.h b/chem/KPP/kpp/kpp-2.1/src/code.h index a40de2de3f..964637c01b 100755 --- a/chem/KPP/kpp/kpp-2.1/src/code.h +++ b/chem/KPP/kpp/kpp-2.1/src/code.h @@ -34,6 +34,7 @@ #define _CODE_H_ #include +#include #include "gdef.h" #define MAX_DEPTH 10 @@ -167,10 +168,10 @@ void CommentFncBegin( int f, int *vars ); void CommentFunctionBegin( int f, ... ); void CommentFunctionEnd( int f ); -void Use_C(); -void Use_F(); -void Use_F90(); -void Use_MATLAB(); +void Use_C( char *rootFileName ); +void Use_F( char *rootFileName ); +void Use_F90( char *rootFileName ); +void Use_MATLAB( char *rootFileName ); extern void (*WriteElm)( NODE *n ); extern void (*WriteSymbol)( int op ); @@ -188,4 +189,14 @@ extern void (*FunctionEnd)( int f ); void WriteDelim(); +/* >>> CL: code_matlab.c */ +extern void MATLAB_Inline( char *fmt, ... ); +/* >>> CL: code_F90.c */ +extern void F90_Inline( char *fmt, ... ); +/* >>> CL: code_F77.c */ +extern void F77_Inline( char *fmt, ... ); +/* >>> CL: gen.c */ +extern int EqnString( int eq, char * buf ); +/* <<< CL */ + #endif diff --git a/chem/KPP/kpp/kpp-2.1/src/code_c.c b/chem/KPP/kpp/kpp-2.1/src/code_c.c index 64deef20a3..ee9b1d0356 100755 --- a/chem/KPP/kpp/kpp-2.1/src/code_c.c +++ b/chem/KPP/kpp/kpp-2.1/src/code_c.c @@ -32,6 +32,7 @@ #include "gdata.h" #include "code.h" +#include "scan.h" #include #define MAX_LINE 120 @@ -366,7 +367,7 @@ char dummy_val[100]; /* used just to avoid strange behaviour of case CONST: bprintf("#define %-20s %-10s ", var->name, val ); break; default: - printf( "Invalid constant", var->type ); + printf( "Invalid constant %d", var->type ); break; } if( varTable[ v ]->comment ) @@ -484,7 +485,7 @@ char buf[ 1000 ]; FlushBuf(); } -void Use_C() +void Use_C( char *rootFileName ) { WriteElm = C_WriteElm; WriteSymbol = C_WriteSymbol; diff --git a/chem/KPP/kpp/kpp-2.1/src/code_f77.c b/chem/KPP/kpp/kpp-2.1/src/code_f77.c index ce8b1e5fe7..e1f4de6921 100755 --- a/chem/KPP/kpp/kpp-2.1/src/code_f77.c +++ b/chem/KPP/kpp/kpp-2.1/src/code_f77.c @@ -529,7 +529,7 @@ char buf[ 1000 ]; } /*************************************************************************************************/ -void Use_F() +void Use_F( char *rootFileName ) { WriteElm = F77_WriteElm; WriteSymbol = F77_WriteSymbol; diff --git a/chem/KPP/kpp/kpp-2.1/src/code_f90.c b/chem/KPP/kpp/kpp-2.1/src/code_f90.c index 5bd7ec6ea9..47a7673eaa 100755 --- a/chem/KPP/kpp/kpp-2.1/src/code_f90.c +++ b/chem/KPP/kpp/kpp-2.1/src/code_f90.c @@ -699,7 +699,7 @@ char buf[ 1000 ]; } /*************************************************************************************************/ -void Use_F90() +void Use_F90( char *rootFileName ) { WriteElm = F90_WriteElm; WriteSymbol = F90_WriteSymbol; diff --git a/chem/KPP/kpp/kpp-2.1/src/code_matlab.c b/chem/KPP/kpp/kpp-2.1/src/code_matlab.c index 9b99b869c4..f9b5ab71ab 100755 --- a/chem/KPP/kpp/kpp-2.1/src/code_matlab.c +++ b/chem/KPP/kpp/kpp-2.1/src/code_matlab.c @@ -32,6 +32,7 @@ #include "gdata.h" #include "code.h" +#include "scan.h" #include #include @@ -673,7 +674,7 @@ char buf[ 1000 ]; } /*************************************************************************************************/ -void Use_MATLAB() +void Use_MATLAB( char *rootFileName ) { WriteElm = MATLAB_WriteElm; WriteSymbol = MATLAB_WriteSymbol; diff --git a/chem/KPP/kpp/kpp-2.1/src/gdata.h b/chem/KPP/kpp/kpp-2.1/src/gdata.h index a9dbf1af73..3e54c689ac 100755 --- a/chem/KPP/kpp/kpp-2.1/src/gdata.h +++ b/chem/KPP/kpp/kpp-2.1/src/gdata.h @@ -36,9 +36,9 @@ #include -#define MAX_EQN 1200 /* mz_rs_20050130 */ -#define MAX_SPECIES 500 /* mz_rs_20050130 */ -#define MAX_SPNAME 30 +#define MAX_EQN 50000 /* 1200 *//* CL *//* mz_rs_20050130 */ +#define MAX_SPECIES 10000 /* 500 *//* CL *//* mz_rs_20050130 */ +#define MAX_SPNAME 50 /* 30 *//* CL */ #define MAX_IVAL 40 /* MAX_EQNTAG = max length of equation ID in eqn file */ #define MAX_EQNTAG 32 @@ -196,7 +196,7 @@ void CmdDriver( char *cmd ); void CmdRun( char *cmd ); void CmdStochastic( char *cmd ); -void Generate(); +void Generate( char *rootFileName ); char * FileName( char *name, char* env, char *dir, char *ext ); diff --git a/chem/KPP/kpp/kpp-2.1/src/gen.c b/chem/KPP/kpp/kpp-2.1/src/gen.c index e80e685e43..986138418a 100755 --- a/chem/KPP/kpp/kpp-2.1/src/gen.c +++ b/chem/KPP/kpp/kpp-2.1/src/gen.c @@ -30,6 +30,8 @@ ******************************************************************************/ +#include +#include #include "gdata.h" #include "code.h" #include "scan.h" @@ -610,11 +612,12 @@ char buf1[100], buf2[100]; if( VarNr == 0 ) return; if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ - - if ( useWRFConform ) - UseFile( integratorFile ); - else - UseFile( functionFile ); + { + if ( useWRFConform ){ + UseFile( integratorFile );} + else{ + UseFile( functionFile ); } + } if ( useWRFConform ) { @@ -756,11 +759,12 @@ char buf1[100], buf2[100]; if( VarNr == 0 ) return; if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ - - if ( useWRFConform ) - UseFile( integratorFile ); - else - UseFile( functionFile ); + { + if ( useWRFConform ) { + UseFile( integratorFile ); } + else { + UseFile( functionFile ); } + } if ( useWRFConform ) { @@ -1099,12 +1103,14 @@ char buf1[100], buf2[100]; if (useJacobian == JAC_OFF) return; if (useLang != MATLAB_LANG) /* Matlab generates an additional file per function */ + { + + if ( useWRFConform ){ + UseFile( integratorFile );} + else { + UseFile( jacobianFile );} + } - if ( useWRFConform ) - UseFile( integratorFile ); - else - UseFile( jacobianFile ); - if ( useWRFConform ){ sprintf( buf1, "%s_Jac_SP", rootFileName ); Jac_SP = DefFnc( buf1, 4, @@ -1932,7 +1938,7 @@ char buf1[100]; sprintf( buf1, "%s_KppSolve", rootFileName ); }else{ UseFile( linalgFile ); - sprintf( buf1, "KppSolve", rootFileName ); + sprintf( buf1, "%s_KppSolve", rootFileName ); } SOLVE = DefFnc( buf1, 2, "sparse back substitution"); @@ -2165,7 +2171,7 @@ int UPDATE_RCONST; F77_Inline(" INCLUDE '%s_Global.h'", rootFileName); MATLAB_Inline("global SUN TEMP RCONST"); - if ( (useLang==F77_LANG) ) + if ( useLang==F77_LANG ) IncludeCode( "%s/util/UserRateLaws_FcnHeader", Home ); NewLines(1); @@ -3380,14 +3386,14 @@ case 't': break; default: - printf("\n Unrecognized option '%s' in GenerateF90Modules\n", where); + printf("\n Unrecognized option '%c' in GenerateF90Modules\n", where); break; } } /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Generate() +void Generate( char *rootFileName ) { int i, j; int n; @@ -3414,7 +3420,7 @@ int n; break; case MATLAB_LANG: Use_MATLAB( rootFileName ); break; - default: printf("\n Language no '%s' unknown\n",useLang ); + default: printf("\n Language no '%d' unknown\n",useLang ); } printf("\nKPP is initializing the code generation."); InitGen(); diff --git a/chem/KPP/kpp/kpp-2.1/src/gen_org.c b/chem/KPP/kpp/kpp-2.1/src/gen_org.c index aef1585162..5b6338fdde 100755 --- a/chem/KPP/kpp/kpp-2.1/src/gen_org.c +++ b/chem/KPP/kpp/kpp-2.1/src/gen_org.c @@ -3075,7 +3075,7 @@ case 't': /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/ -void Generate() +void Generate( char *rootFileName ) { int i, j; int n; diff --git a/chem/KPP/kpp/kpp-2.1/src/kpp.c b/chem/KPP/kpp/kpp-2.1/src/kpp.c index 22d2fd68df..4343a4e51b 100755 --- a/chem/KPP/kpp/kpp-2.1/src/kpp.c +++ b/chem/KPP/kpp/kpp-2.1/src/kpp.c @@ -457,7 +457,7 @@ for (i=0; i +#include #include "gdef.h" /* mz_rs_20050518+ value increased */ -#define MAX_INLINE 30000 +#define MAX_INLINE 50000 /* 30000 *//* CL further increased */ /* #define MAX_INLINE 4000 */ /* mz_rs_20050518- */ @@ -97,7 +98,7 @@ void WriteSpecies(); void WriteMatrices(); void WriteOptions(); -void yyerror() ; +void yyerror( char * str ) ; void ParserErrorMessage() ; char * AppendString( char * s1, char * s2, int * len, int addlen ); @@ -107,4 +108,28 @@ void AddInlineCode( char * context, char * code ); int yyerrflag ; #endif +/* >>> CL: scanner.c */ +extern void CmdStoicmat( char *cmd ); +extern void CheckAll(); +extern void LookAtAll(); +extern void TransportAll(); +extern void DefineInitializeNbr( char *cmd ); +extern void DefineXGrid( char *cmd ); +extern void DefineYGrid( char *cmd ); +extern void DefineZGrid( char *cmd ); +extern void SparseData( char *cmd ); +extern void AddUseFile( char *fname ); +extern void WRFConform(); +extern int ParseEquationFile( char * filename ); + +/* >>> CL: scan.l */ +extern int EqNoCase( char *s1, char *s2 ); + +/* >>> CL: scan.y */ +extern int yylex(void); +/* <<< CL */ + +/* <<< CL */ + + #endif diff --git a/chem/KPP/kpp/kpp-2.1/src/scan.l b/chem/KPP/kpp/kpp-2.1/src/scan.l index 84a74e2ff8..b8ae115ed3 100755 --- a/chem/KPP/kpp/kpp-2.1/src/scan.l +++ b/chem/KPP/kpp/kpp-2.1/src/scan.l @@ -30,7 +30,6 @@ ******************************************************************************/ - %s CMD_STATE INC_STATE MOD_STATE INT_STATE %s PRM_STATE DSP_STATE SSP_STATE INI_STATE EQN_STATE EQNTAG_STATE %s RATE_STATE LMP_STATE CR_IGNORE SC_IGNORE ATM_STATE LKT_STATE INL_STATE @@ -43,7 +42,6 @@ #include "scan.h" #include "y.tab.h" - void*malloc() ; void Include ( char * filename ); int EndInclude(); diff --git a/chem/KPP/kpp/kpp-2.1/src/scan.y b/chem/KPP/kpp/kpp-2.1/src/scan.y index 0ff3ae3d5c..7810ab08f5 100755 --- a/chem/KPP/kpp/kpp-2.1/src/scan.y +++ b/chem/KPP/kpp/kpp-2.1/src/scan.y @@ -38,6 +38,7 @@ #include #include #include "scan.h" + #include "gdata.h" #define __YYSCLASS @@ -45,7 +46,7 @@ extern char yytext[]; extern FILE * yyin; /* extern int yyerrstatus; */ - + int nError = 0; int nWarning = 0; @@ -65,7 +66,7 @@ %} %union{ - char str[80]; + char str[500]; }; %token JACOBIAN DOUBLE FUNCTION DEFVAR DEFRAD DEFFIX SETVAR SETRAD SETFIX diff --git a/chem/KPP/util/wkc/Makefile b/chem/KPP/util/wkc/Makefile index 86954eb2a3..92e44f5c83 100644 --- a/chem/KPP/util/wkc/Makefile +++ b/chem/KPP/util/wkc/Makefile @@ -6,7 +6,7 @@ include ../../configure.kpp CFLAGS = #-ansi LDFLAGS = -DEBUG = -g +DEBUG = -O0 -g OBJ = registry_kpp.o my_strtok.o data.o type.o misc.o reg_parse.o \ gen_kpp.o get_wrf_chem_specs.o gen_kpp_mech_dr.o gen_kpp_interface.o \ get_kpp_chem_specs.o compare_kpp_to_species.o get_wrf_radicals.o \ diff --git a/chem/KPP/util/wkc/change_chem_Makefile.c b/chem/KPP/util/wkc/change_chem_Makefile.c index cf3226b58a..1b2676cb7c 100644 --- a/chem/KPP/util/wkc/change_chem_Makefile.c +++ b/chem/KPP/util/wkc/change_chem_Makefile.c @@ -1,4 +1,6 @@ #include +#include +#include #include "protos.h" @@ -8,7 +10,7 @@ -int +void change_chem_Makefile ( ) { knode_t * p1, * p2, * pm1; @@ -45,7 +47,7 @@ knode_t * p1, * p2, * pm1; while ( fgets ( inln , NAMELEN , ch_Makefile ) != NULL ){ /* printf("%s ", inln ); */ - fprintf(t_Makefile, inln); + fprintf(t_Makefile, "%s", inln); /* if ( strncmp(inln, "MODULES",6) == 0){ */ diff --git a/chem/KPP/util/wkc/compare_kpp_to_species.c b/chem/KPP/util/wkc/compare_kpp_to_species.c index 8a6151148c..bd492327f1 100644 --- a/chem/KPP/util/wkc/compare_kpp_to_species.c +++ b/chem/KPP/util/wkc/compare_kpp_to_species.c @@ -72,7 +72,7 @@ compare_kpp_to_species ( char * kpp_dirname) for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { p2 = p1->assoc_wrf_pack; - printf(" ... testing %s %s\n",p1, p2 ); + printf(" ... testing %s %s\n",p1->name, p2->name ); if ( p2 ) { fprintf(stderr, "\n \n FOUND match between WRF-Chem/KPP for mechanism: %s \n", p2->name); diff --git a/chem/KPP/util/wkc/gen_kpp.c b/chem/KPP/util/wkc/gen_kpp.c index 85346c0f59..63dcd2f853 100644 --- a/chem/KPP/util/wkc/gen_kpp.c +++ b/chem/KPP/util/wkc/gen_kpp.c @@ -62,102 +62,7 @@ in ~WRF: chem/KPP/util/wkc/registry_kpp Registry/Registry */ -int -gen_kpp ( char * inc_dirname, char * kpp_dirname ) -{ - - - - /* put chem compound names defined in Registry into linked list WRFC_packs */ - - if ( DEBUGR == 1 ) printf("next: get_wrf_chem_specs \n"); - get_wrf_chem_specs () ; - if ( DEBUGR == 2 ) write_list_to_screen( WRFC_packs ) ; - - - - - /* put radical names defined in Registry into linked list WRFC_radicals */ - - if ( DEBUGR == 1 ) printf("next: get_wrf_radicals \n"); - get_wrf_radicals () ; - if ( DEBUGR == 2 ) write_list_to_screen( WRFC_radicals ) ; - - - /* put photolysis rates defined in Registry into linked list WRFC_jvals */ - - if ( DEBUGR == 1 ) printf("next: get_wrf_jvals \n"); - get_wrf_jvals () ; - if ( DEBUGR == 2 ) write_list_to_screen( WRFC_jvals ) ; - - - /* read KPP species files and put compound names into linked list KPP_packs */ - if ( DEBUGR == 1 ) printf("next: get_kpp_chem_specs \n"); - get_kpp_chem_specs ( kpp_dirname ) ; - if ( DEBUGR == 2 ) {write_list_to_screen( KPP_packs ) ;} - - - - - - /* define pointer from each KPP package to corresponding WRF-Chem chemistry package and check whether variable names are consistent. If *_wrfkpp.equiv file exists in KPP directory use it for name matching */ - - - if ( DEBUGR == 1 ) printf("next: compare_kpp_to_species \n"); - compare_kpp_to_species ( kpp_dirname ); - - - - - - /* write some output to screen */ - if ( DEBUGR == 1 ) printf("next: screen_out \n"); - screen_out( ); - - - /* make sure that wrf and kpp variables match and stop if not. */ - if ( DEBUGR == 1 ) printf("next: check_all \n"); - check_all ( kpp_dirname ); - - - - /* add the kpp generated modules to the Makefile in the chem directory */ - if ( DEBUGR == 1 ) printf("next: change_chem_Makefile \n"); - change_chem_Makefile ( ); - - - - - /* write the mechanism driver */ - if ( DEBUGR == 1 ) printf("next: gen_kpp_mechanism_driver (writing chem/kpp_mechanism_driver.F) \n"); - gen_kpp_mechanism_driver ( ); - - - if ( DEBUGR == 1 ) printf("next: gen_call_to_kpp_mechanism_driver (writing inc/call_to_kpp_mech_drive.inc) \n"); - gen_kpp_call_to_mech_dr ( ); - - - /* write arguments for call to KPPs Update_Rconst */ - if ( DEBUGR == 1 ) printf("next: gen_kpp_args_to_Update_Rconst (writing inc/args_to_update_rconst.inc and inc/ +#include +#include #include "protos.h" @@ -6,7 +8,7 @@ #include "kpp_data.h" -int +void decl_misc ( FILE * ofile ) { @@ -42,7 +44,7 @@ decl_misc ( FILE * ofile ) fprintf(ofile," \n\n\n\n "); } -int +void decl_jv ( FILE * ofile ) { int n; @@ -73,7 +75,7 @@ count_members( knode_t * nl ) -int +void decl_jv_pointers ( FILE * ofile ) { knode_t * pl; @@ -103,7 +105,7 @@ decl_jv_pointers ( FILE * ofile ) } -int +void gen_map_jval ( FILE * ofile ) { knode_t * pl; @@ -126,8 +128,7 @@ gen_map_jval ( FILE * ofile ) - -int +void gen_map_wrf_to_kpp ( FILE * ofile, knode_t * nl ) { knode_t * pml; @@ -154,7 +155,7 @@ gen_map_wrf_to_kpp ( FILE * ofile, knode_t * nl ) -int +void gen_map_kpp_to_wrf ( FILE * ofile, knode_t * nl ) { knode_t * pml; @@ -180,7 +181,7 @@ gen_map_kpp_to_wrf ( FILE * ofile, knode_t * nl ) } -int +void gen_kpp_pargs( FILE * ofile, knode_t * nl ) { knode_t * pml; @@ -217,7 +218,7 @@ gen_kpp_pargs( FILE * ofile, knode_t * nl ) } -int +void gen_kpp_pdecl( FILE * ofile, knode_t * nl ) { knode_t * pml; @@ -255,7 +256,7 @@ gen_kpp_pdecl( FILE * ofile, knode_t * nl ) } -int +void wki_start_loop( FILE * ofile ) { @@ -264,7 +265,7 @@ wki_start_loop( FILE * ofile ) fprintf(ofile," DO i=its, ite\n\n\n"); } -int +void wki_end_loop( FILE * ofile ) { @@ -274,7 +275,7 @@ wki_end_loop( FILE * ofile ) } -int +void wki_prelim( FILE * ofile ) { @@ -303,7 +304,7 @@ wki_prelim( FILE * ofile ) } -int +void wki_one_d_vars( FILE * ofile, knode_t * pp ) { diff --git a/chem/KPP/util/wkc/gen_kpp_interface.c b/chem/KPP/util/wkc/gen_kpp_interface.c index 03abb61679..46ac0a978d 100644 --- a/chem/KPP/util/wkc/gen_kpp_interface.c +++ b/chem/KPP/util/wkc/gen_kpp_interface.c @@ -1,4 +1,5 @@ #include +#include #include "protos.h" @@ -7,7 +8,7 @@ -int +void gen_kpp_interface ( ) { knode_t * p1, * p2, * pm1; diff --git a/chem/KPP/util/wkc/gen_kpp_mech_dr.c b/chem/KPP/util/wkc/gen_kpp_mech_dr.c index da1d7ab39c..8b0140c1e7 100644 --- a/chem/KPP/util/wkc/gen_kpp_mech_dr.c +++ b/chem/KPP/util/wkc/gen_kpp_mech_dr.c @@ -1,5 +1,6 @@ #include +#include #include "protos.h" @@ -9,7 +10,7 @@ /*---------------------------------------------------------------------*/ -int +void gen_kpp_mechanism_driver ( ) { knode_t * p1, * p2, * p3, * p4, * pm1, * pm3, * pm4; @@ -112,7 +113,7 @@ knode_t * p1, * p2, * p3, * p4, * pm1, * pm3, * pm4; -int +void gen_kpp_call_to_mech_dr ( ) { knode_t * p1, * p2, * p3, * p4, * pm1, * pm3, * pm4; diff --git a/chem/KPP/util/wkc/gen_kpp_utils.c b/chem/KPP/util/wkc/gen_kpp_utils.c index 52343f0a40..26afa0bebb 100644 --- a/chem/KPP/util/wkc/gen_kpp_utils.c +++ b/chem/KPP/util/wkc/gen_kpp_utils.c @@ -6,7 +6,7 @@ #include "kpp_data.h" -int gen_kpp_warning( FILE * ofile, char * gen_by_name, char*cchar ) +void gen_kpp_warning( FILE * ofile, char * gen_by_name, char*cchar ) { fprintf(ofile, "%s \n", cchar); fprintf(ofile, "%s THIS FILE WAS AUTOMATICALLY GENERATED BY \n%s\n",cchar,cchar ); @@ -17,8 +17,7 @@ int gen_kpp_warning( FILE * ofile, char * gen_by_name, char*cchar ) -int -gen_kpp_pass_down ( FILE * ofile, int is_driver ) +void gen_kpp_pass_down ( FILE * ofile, int is_driver ) { fprintf(ofile,"!\n"); @@ -39,8 +38,7 @@ gen_kpp_pass_down ( FILE * ofile, int is_driver ) } -int -gen_kpp_decl ( FILE * ofile, int is_driver ) +void gen_kpp_decl ( FILE * ofile, int is_driver ) { /* declare dimensions */ gen_kpp_decld ( ofile, is_driver ); @@ -71,7 +69,7 @@ gen_kpp_decl ( FILE * ofile, int is_driver ) } -int gen_kpp_argl( FILE * ofile, knode_t * nl ) +void gen_kpp_argl( FILE * ofile, knode_t * nl ) { knode_t * pml; int countit; @@ -98,7 +96,7 @@ int gen_kpp_argl( FILE * ofile, knode_t * nl ) -int gen_kpp_argl_new( FILE * ofile, knode_t * nl ) +void gen_kpp_argl_new( FILE * ofile, knode_t * nl ) { knode_t * pml; int countit; @@ -127,7 +125,7 @@ int gen_kpp_argl_new( FILE * ofile, knode_t * nl ) -int gen_kpp_argd ( FILE * ofile, int is_driver ) +void gen_kpp_argd ( FILE * ofile, int is_driver ) { fprintf(ofile, " ids,ide, jds,jde, kds,kde, &\n"); fprintf(ofile, " ims,ime, jms,jme, kms,kme, &\n"); @@ -138,7 +136,7 @@ int gen_kpp_argd ( FILE * ofile, int is_driver ) } -int gen_kpp_decld ( FILE * ofile, int is_driver ) +void gen_kpp_decld ( FILE * ofile, int is_driver ) { fprintf(ofile, "\n\n\n INTEGER, INTENT(IN ) :: &\n"); fprintf(ofile, " ids,ide, jds,jde, kds,kde, & \n"); @@ -151,7 +149,7 @@ int gen_kpp_decld ( FILE * ofile, int is_driver ) } } -int gen_kpp_decl3d( FILE * ofile, knode_t * nl ) +void gen_kpp_decl3d( FILE * ofile, knode_t * nl ) { knode_t * pml; int countit; diff --git a/chem/KPP/util/wkc/get_kpp_chem_specs.c b/chem/KPP/util/wkc/get_kpp_chem_specs.c index 318c21970f..6130400a9b 100644 --- a/chem/KPP/util/wkc/get_kpp_chem_specs.c +++ b/chem/KPP/util/wkc/get_kpp_chem_specs.c @@ -39,14 +39,14 @@ int in_comment, got_it; if (!dir) { fprintf(stderr, "WARNING from gen_kpp: Cannot read directory: %s \n", kpp_dirname); perror(""); - return; + return(0); // return; } /* loop through sub directories in KPP directory */ while ((entry = readdir(dir))) { - if (entry->d_name ) { + if ( strlen(entry->d_name) > 0 ) { if ( strcmp(entry->d_name, ".") == 0) continue; diff --git a/chem/KPP/util/wkc/get_wrf_jvals.c b/chem/KPP/util/wkc/get_wrf_jvals.c index 3a0ac0c53b..eb828e5942 100644 --- a/chem/KPP/util/wkc/get_wrf_jvals.c +++ b/chem/KPP/util/wkc/get_wrf_jvals.c @@ -1,4 +1,5 @@ #include +#include #include "protos.h" diff --git a/chem/KPP/util/wkc/get_wrf_radicals.c b/chem/KPP/util/wkc/get_wrf_radicals.c index d7e5e0adfe..a250ba2fbd 100644 --- a/chem/KPP/util/wkc/get_wrf_radicals.c +++ b/chem/KPP/util/wkc/get_wrf_radicals.c @@ -1,4 +1,5 @@ #include +#include #include "protos.h" #include "protos_kpp.h" diff --git a/chem/KPP/util/wkc/kpp_data.c b/chem/KPP/util/wkc/kpp_data.c index 2a779b8f00..b7f0362a4e 100644 --- a/chem/KPP/util/wkc/kpp_data.c +++ b/chem/KPP/util/wkc/kpp_data.c @@ -11,7 +11,7 @@ knode_t * -new_knode ( int * kind ) +new_knode ( ) { knode_t *p ; p = (knode_t *)malloc(sizeof(knode_t)) ; bzero(p,sizeof(knode_t)); return (p) ; } int diff --git a/chem/KPP/util/wkc/protos_kpp.h b/chem/KPP/util/wkc/protos_kpp.h index 12ce92b3f8..e1f6c41b65 100644 --- a/chem/KPP/util/wkc/protos_kpp.h +++ b/chem/KPP/util/wkc/protos_kpp.h @@ -2,7 +2,7 @@ #include "kpp_data.h" /* added for gen_kpp */ -knode_t * new_knode () ; +knode_t * new_knode ( ) ; int add_knode_to_end ( knode_t * node , knode_t ** list ) ; int gen_kpp (char * dirname1, char * dirname2); @@ -18,13 +18,13 @@ int compare_kpp_to_species ( char * kpp_dirname) ; int run_kpp( char * dirname , char * kpp_version ); -int change_chem_Makefile( ); +void change_chem_Makefile( ); -int gen_kpp_mechanism_driver ( ); -int gen_kpp_call_to_mech_dr ( ); -int gen_kpp_args_to_Update_Rconst ( ); -int gen_kpp_interface( ); +void gen_kpp_mechanism_driver ( ); +void gen_kpp_call_to_mech_dr ( ); +void gen_kpp_args_to_Update_Rconst ( ); +void gen_kpp_interface( ); int debug_out( ); @@ -35,30 +35,30 @@ int debug_out( ); /* added gen_kpp utils */ -int gen_kpp_warning( FILE * ofile, char * gen_by_name, char * cchar ); -int gen_kpp_pass_down ( FILE * ofile, int is_driver ); -int gen_kpp_decl ( FILE * ofile, int is_driver ); -int gen_kpp_argl( FILE * ofile , knode_t * nl ); -int gen_kpp_argl_new( FILE * ofile , knode_t * nl ); -int gen_kpp_argd ( FILE * ofile, int is_driver ); -int gen_kpp_decld ( FILE * ofile, int is_driver ); -int gen_kpp_decl3d( FILE * ofile, knode_t * nl ); +void gen_kpp_warning( FILE * ofile, char * gen_by_name, char * cchar ); +void gen_kpp_pass_down ( FILE * ofile, int is_driver ); +void gen_kpp_decl ( FILE * ofile, int is_driver ); +void gen_kpp_argl( FILE * ofile , knode_t * nl ); +void gen_kpp_argl_new( FILE * ofile , knode_t * nl ); +void gen_kpp_argd ( FILE * ofile, int is_driver ); +void gen_kpp_decld ( FILE * ofile, int is_driver ); +void gen_kpp_decl3d( FILE * ofile, knode_t * nl ); /* added gen_kpp_interf utils */ -int decl_misc ( FILE * ofile ); -int decl_jv ( FILE * ofile ); +void decl_misc ( FILE * ofile ); +void decl_jv ( FILE * ofile ); int count_members( knode_t * nl ); -int decl_jv_pointers ( FILE * ofile ); -int decl_kwc_constants ( FILE * ofile ); -int gen_map_jval( FILE * ofile ); -int gen_map_wrf_to_kpp ( FILE * ofile, knode_t * nl ); -int gen_map_kpp_to_wrf ( FILE * ofile, knode_t * nl ); -int gen_kpp_pargs( FILE * ofile, knode_t * nl ); -int gen_kpp_pdecl( FILE * ofile, knode_t * nl ); -int wki_prelim( FILE * ofile ); -int wki_start_loop( FILE * ofile ); -int wki_end_loop( FILE * ofile ); -int wki_one_d_vars ( FILE * ofile, knode_t * pp ); +void decl_jv_pointers ( FILE * ofile ); +void decl_kwc_constants ( FILE * ofile ); +void gen_map_jval( FILE * ofile ); +void gen_map_wrf_to_kpp ( FILE * ofile, knode_t * nl ); +void gen_map_kpp_to_wrf ( FILE * ofile, knode_t * nl ); +void gen_kpp_pargs( FILE * ofile, knode_t * nl ); +void gen_kpp_pdecl( FILE * ofile, knode_t * nl ); +void wki_prelim( FILE * ofile ); +void wki_start_loop( FILE * ofile ); +void wki_end_loop( FILE * ofile ); +void wki_one_d_vars ( FILE * ofile, knode_t * pp ); #define PROTOS_H_KPP #endif diff --git a/chem/KPP/util/wkc/registry_kpp.c b/chem/KPP/util/wkc/registry_kpp.c index c9b6b60ec4..ec78bac6d7 100644 --- a/chem/KPP/util/wkc/registry_kpp.c +++ b/chem/KPP/util/wkc/registry_kpp.c @@ -13,7 +13,7 @@ #include "data.h" #include "sym.h" -main( int argc, char *argv[], char *env[] ) +int main( int argc, char *argv[], char *env[] ) { char fname_in[NAMELEN], dir[NAMELEN], fname_tmp[NAMELEN], command[NAMELEN] ; FILE * fp_in, *fp_tmp ; diff --git a/chem/KPP/util/write_decomp/integr_edit.c b/chem/KPP/util/write_decomp/integr_edit.c index 756e04d135..82faae53c4 100644 --- a/chem/KPP/util/write_decomp/integr_edit.c +++ b/chem/KPP/util/write_decomp/integr_edit.c @@ -1,5 +1,6 @@ #include #include +#include #define NAMELEN 4096 @@ -7,6 +8,7 @@ /* replace decomp routine in KPP Integr file */ +int main( int argc, char *argv[] ) { diff --git a/chem/chem_driver.F b/chem/chem_driver.F index 4c8268df1b..8650b9444a 100755 --- a/chem/chem_driver.F +++ b/chem/chem_driver.F @@ -282,6 +282,8 @@ end SUBROUTINE sum_pm_driver CHARACTER (LEN=1000) :: msg CHARACTER (LEN=256) :: current_date_char integer :: current_month +!for the online nh3-"WRF-NH3-CHEM" modified by renchuanhua + integer :: current_hour ! .. ! .. Intrinsic Functions .. INTRINSIC max, min @@ -878,9 +880,14 @@ end SUBROUTINE sum_pm_driver grid%biomt_par,grid%emit_par,grid%ebio_co2oce, & eghg_bio, & grid%seas_flux, & + ! stuff for the online nh3-"WRF-NH3-CHEM" modified by renchuanhua + grid%actnh3, grid%EFnh3, & + grid%agrisoil_nh3, grid%fertilizer_nh3, grid%freeinten_nh3, & + grid%graze_nh3, grid%industry_nh3, & + grid%residential_nh3, grid%transport_nh3, current_hour, grid%Q2, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite,jts,jte,kts,kte) + its,ite,jts,jte,kts,kte ) if( chm_is_mozart ) then call mozcart_lbc_set( chem, num_chem, grid%id, & ims, ime, jms, jme, kms, kme, & diff --git a/chem/chemics_init.F b/chem/chemics_init.F index 59f0546883..9856ba9dc5 100755 --- a/chem/chemics_init.F +++ b/chem/chemics_init.F @@ -37,6 +37,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_mozcart_wetscav, only : wetscav_mozcart_init USE module_aerosols_sorgam USE module_aerosols_soa_vbs, only: aerosols_soa_vbs_init + USE module_aerosols_soa_vbs_het, only: aerosols_soa_vbs_het_init USE module_aerosols_sorgam_vbs, only: aerosols_sorgam_vbs_init USE module_dep_simple USE module_data_gocart_dust @@ -65,7 +66,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_ctrans_grell, only: conv_tr_wetscav_init !!! TUCCELLA (BUG) - USE module_prep_wetscav_sorgam, only: aerosols_sorgam_init_aercld_ptrs, aerosols_soa_vbs_init_aercld_ptrs + USE module_prep_wetscav_sorgam, only: aerosols_sorgam_init_aercld_ptrs, aerosols_soa_vbs_init_aercld_ptrs !!CYY USE module_model_constants, only:t0 @@ -120,7 +121,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, z_at_w,t,p,alt,convfac REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , & INTENT(INOUT ) :: & - chem + chem REAL, DIMENSION( ims:ime , 1:kemit , jms:jme, num_emis_ant ) , & INTENT(INOUT ) :: & emis_ant @@ -137,7 +138,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, integer, intent(out) :: stepbioe,stepphot,stepchem,stepfirepl TYPE (grid_config_rec_type) , INTENT (in) :: config_flags TYPE(domain) , INTENT (inout) :: grid - + REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: si_zsigf, si_zsig ! @@ -169,7 +170,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, numgas = get_last_gas(config_flags%chem_opt) numgas_out = numgas - + chem_select: SELECT CASE(config_flags%chem_opt) CASE (GOCART_SIMPLE) CALL wrf_debug(15,'calling only gocart aerosols driver from chem_driver') @@ -337,8 +338,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 109 or 503 or 504 or 601 or 611 to function.") endif if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 & - .and. config_flags%mp_physics /= 17 .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22) then - call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 17/18/22 NSSL_2mom to function.") + .and. .not. ( config_flags%mp_physics == 18 .and. config_flags%nssl_2moment_on == 1 ) ) then + call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 18 NSSL_2mom to function.") endif elseif( id == 1 ) then if ( config_flags%mp_physics /= 6 .and. config_flags%mp_physics /= 8 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 17 & @@ -375,8 +376,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, !BSINGH - kfcup schme only works with Mosaic aqueoue packages: ! *** NOTE *** ! KFCUP should in theory work with any chem_opt package that uses MOSAIC and has cloud-borne aerosols (*_aq*). - ! However, it was only tested with chem_opt=203 (saprc99_mosaic_8bin_vbs2_aq_kpp) - ! during implementation into WRF-Chem in April 2017 at PNNL. + ! However, it was only tested with chem_opt=203 (saprc99_mosaic_8bin_vbs2_aq_kpp) + ! during implementation into WRF-Chem in April 2017 at PNNL. if ( config_flags%cu_physics == 10) then if( config_flags%chem_opt /= 9 .and. config_flags%chem_opt /= 10 .and. & config_flags%chem_opt /= 32 .and. config_flags%chem_opt /= 34 .and. & @@ -426,6 +427,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal( trim(message_txt) ) endif + ! osipov check that ddflx & ddlen has correct dim size (chem_opt=106 and such) + if ( config_flags%diagnostic_dep .EQ. 1 .AND. config_flags%ne_area .LT. num_chem ) then + write(message_txt,'(''ERROR: SORGAM diagnostic_dep 1 requires ne_area('',i6,'') >= num_chem('',i6,'')'')') config_flags%ne_area,num_chem + call wrf_error_fatal( trim(message_txt) ) + endif + IF ( config_flags%chem_opt == 0 .AND. config_flags%aer_ra_feedback .NE. 0 ) THEN ! config_flags%aer_ra_feedback = 0 call wrf_error_fatal(" ERROR: CHEM_INIT: FOR CHEM_OPT = 0, AER_RA_FEEDBACK MUST = 0 ") @@ -449,7 +456,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal(" ERROR: CHEM_INIT: MUST HAVE AEROSOLS TO INCLUDE AEROSOL RADIATION FEEDBACK. SET AER_RA_FEEDBACK = 0 ") ENDIF - if ( config_flags%n2o5_hetchem == 1 )then + if ( config_flags%n2o5_hetchem == 1 )then if( (config_flags%chem_opt >= 7 .AND. config_flags%chem_opt <= 10) .OR. & (config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 34) .OR. & config_flags%chem_opt == 170 .OR. config_flags%chem_opt == 198 .OR. & @@ -488,7 +495,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ENDIF ENDIF !-- - + !-- Load dgnum arrays when restart is active IF ( config_flags%restart ) THEN do j=jts,jte @@ -497,7 +504,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, dgnum4d(i, k, j, 1) = dgnum_a1(i, k, j) dgnum4d(i, k, j, 2) = dgnum_a2(i, k, j) dgnum4d(i, k, j, 3) = dgnum_a3(i, k, j) - + dgnumwet4d(i, k, j, 1) = dgnumwet_a1(i, k, j) dgnumwet4d(i, k, j, 2) = dgnumwet_a2(i, k, j) dgnumwet4d(i, k, j, 3) = dgnumwet_a3(i, k, j) @@ -718,7 +725,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, do j=jts,jte do k=kts,kte do i=its,ite - chem(i,k,j,p_co2)=400. + chem(i,k,j,p_co2)=400. chem(i,k,j,p_ch4)=1.7 chem(i,k,j,p_ete)=chem(i,k,j,p_olt) chem(i,k,j,p_ete)=epsilc @@ -802,7 +809,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo enddo - endif + endif CASE (MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP) grid%vbs_nbin=0 if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then @@ -921,7 +928,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_smpa_a02.gt.1) chem(i,k,j,p_smpa_a02)=1.e-16 if (p_smpa_a03.gt.1) chem(i,k,j,p_smpa_a03)=1.e-16 if (p_smpa_a04.gt.1) chem(i,k,j,p_smpa_a04)=1.e-16 - + if (p_smpbb_a01.gt.1) chem(i,k,j,p_smpbb_a01)=1.e-16 if (p_smpbb_a02.gt.1) chem(i,k,j,p_smpbb_a02)=1.e-16 if (p_smpbb_a03.gt.1) chem(i,k,j,p_smpbb_a03)=1.e-16 @@ -1039,7 +1046,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo endif - + !BSINGH(04/03/2014): Added 8 bin vbs non-aq pakage CASE (SAPRC99_MOSAIC_8BIN_VBS2_KPP) if(config_flags%chem_in_opt == 0 )then @@ -1144,8 +1151,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_sesq.gt.1) chem(i,k,j,p_sesq)=0.0 if (p_aro1.gt.1) chem(i,k,j,p_aro1)=0.0 if (p_aro2.gt.1) chem(i,k,j,p_aro2)=0.0 - - + + if (p_pcg1_b_c_a01.gt.1) chem(i,k,j,p_pcg1_b_c_a01)=0.0 if (p_pcg1_b_o_a01.gt.1) chem(i,k,j,p_pcg1_b_o_a01)=0.0 if (p_opcg1_b_c_a01.gt.1) chem(i,k,j,p_opcg1_b_c_a01)=0.0 @@ -1164,8 +1171,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a01.gt.1) chem(i,k,j,p_biog2_o_a01)=0.0 if (p_ant3_c_a01.gt.1) chem(i,k,j,p_ant3_c_a01)=0.0 if (p_ant4_c_a01.gt.1) chem(i,k,j,p_ant4_c_a01)=0.0 - - + + if (p_pcg1_b_c_a02.gt.1) chem(i,k,j,p_pcg1_b_c_a02)=0.0 if (p_pcg1_b_o_a02.gt.1) chem(i,k,j,p_pcg1_b_o_a02)=0.0 if (p_opcg1_b_c_a02.gt.1) chem(i,k,j,p_opcg1_b_c_a02)=0.0 @@ -1184,9 +1191,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a02.gt.1) chem(i,k,j,p_biog2_o_a02)=0.0 if (p_ant3_c_a02.gt.1) chem(i,k,j,p_ant3_c_a02)=0.0 if (p_ant4_c_a02.gt.1) chem(i,k,j,p_ant4_c_a02)=0.0 - - - + + + if (p_pcg1_b_c_a03.gt.1) chem(i,k,j,p_pcg1_b_c_a03)=0.0 if (p_pcg1_b_o_a03.gt.1) chem(i,k,j,p_pcg1_b_o_a03)=0.0 if (p_opcg1_b_c_a03.gt.1) chem(i,k,j,p_opcg1_b_c_a03)=0.0 @@ -1205,8 +1212,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a03.gt.1) chem(i,k,j,p_biog2_o_a03)=0.0 if (p_ant3_c_a03.gt.1) chem(i,k,j,p_ant3_c_a03)=0.0 if (p_ant4_c_a03.gt.1) chem(i,k,j,p_ant4_c_a03)=0.0 - - + + if (p_pcg1_b_c_a04.gt.1) chem(i,k,j,p_pcg1_b_c_a04)=0.0 if (p_pcg1_b_o_a04.gt.1) chem(i,k,j,p_pcg1_b_o_a04)=0.0 if (p_opcg1_b_c_a04.gt.1) chem(i,k,j,p_opcg1_b_c_a04)=0.0 @@ -1225,8 +1232,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a04.gt.1) chem(i,k,j,p_biog2_o_a04)=0.0 if (p_ant3_c_a04.gt.1) chem(i,k,j,p_ant3_c_a04)=0.0 if (p_ant4_c_a04.gt.1) chem(i,k,j,p_ant4_c_a04)=0.0 - - + + if (p_pcg1_b_c_a05.gt.1) chem(i,k,j,p_pcg1_b_c_a05)=0.0 if (p_pcg1_b_o_a05.gt.1) chem(i,k,j,p_pcg1_b_o_a05)=0.0 if (p_opcg1_b_c_a05.gt.1) chem(i,k,j,p_opcg1_b_c_a05)=0.0 @@ -1245,8 +1252,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a05.gt.1) chem(i,k,j,p_biog2_o_a05)=0.0 if (p_ant3_c_a05.gt.1) chem(i,k,j,p_ant3_c_a05)=0.0 if (p_ant4_c_a05.gt.1) chem(i,k,j,p_ant4_c_a05)=0.0 - - + + if (p_pcg1_b_c_a06.gt.1) chem(i,k,j,p_pcg1_b_c_a06)=0.0 if (p_pcg1_b_o_a06.gt.1) chem(i,k,j,p_pcg1_b_o_a06)=0.0 if (p_opcg1_b_c_a06.gt.1) chem(i,k,j,p_opcg1_b_c_a06)=0.0 @@ -1265,8 +1272,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a06.gt.1) chem(i,k,j,p_biog2_o_a06)=0.0 if (p_ant3_c_a06.gt.1) chem(i,k,j,p_ant3_c_a06)=0.0 if (p_ant4_c_a06.gt.1) chem(i,k,j,p_ant4_c_a06)=0.0 - - + + if (p_pcg1_b_c_a07.gt.1) chem(i,k,j,p_pcg1_b_c_a07)=0.0 if (p_pcg1_b_o_a07.gt.1) chem(i,k,j,p_pcg1_b_o_a07)=0.0 if (p_opcg1_b_c_a07.gt.1) chem(i,k,j,p_opcg1_b_c_a07)=0.0 @@ -1285,8 +1292,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a07.gt.1) chem(i,k,j,p_biog2_o_a07)=0.0 if (p_ant3_c_a07.gt.1) chem(i,k,j,p_ant3_c_a07)=0.0 if (p_ant4_c_a07.gt.1) chem(i,k,j,p_ant4_c_a07)=0.0 - - + + if (p_pcg1_b_c_a08.gt.1) chem(i,k,j,p_pcg1_b_c_a08)=0.0 if (p_pcg1_b_o_a08.gt.1) chem(i,k,j,p_pcg1_b_o_a08)=0.0 if (p_opcg1_b_c_a08.gt.1) chem(i,k,j,p_opcg1_b_c_a08)=0.0 @@ -1305,19 +1312,19 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o_a08.gt.1) chem(i,k,j,p_biog2_o_a08)=0.0 if (p_ant3_c_a08.gt.1) chem(i,k,j,p_ant3_c_a08)=0.0 if (p_ant4_c_a08.gt.1) chem(i,k,j,p_ant4_c_a08)=0.0 - - - + + + enddo enddo enddo endif !BSINGH(04/03/2014):ENDS - - - !BSINGH(12/03/2013) - Added case statement for SAPRC 8 bin + + + !BSINGH(12/03/2013) - Added case statement for SAPRC 8 bin CASE (SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP )!BSINGH (12/11/13): Got rid of SAPRC99_MOSAIC_4BIN_VBS2_AQ_KPP and SAPRC99_MOSAIC_4BIN_VBS2_KPP - + if(config_flags%chem_in_opt == 1 ) grid%vbs_nbin=2 if(config_flags%chem_in_opt == 0 )then grid%vbs_nbin=2 @@ -1410,7 +1417,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_biog2_o.gt.1) chem(i,k,j,p_biog2_o)=0.0 if (p_biog3_o.gt.1) chem(i,k,j,p_biog3_o)=0.0 if (p_biog4_o.gt.1) chem(i,k,j,p_biog4_o)=0.0 - + if (p_pcg1_b_c_a01.gt.1) chem(i,k,j,p_pcg1_b_c_a01)=0.0 if (p_pcg1_b_o_a01.gt.1) chem(i,k,j,p_pcg1_b_o_a01)=0.0 if (p_opcg1_b_c_a01.gt.1) chem(i,k,j,p_opcg1_b_c_a01)=0.0 @@ -1421,7 +1428,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a01.gt.1) chem(i,k,j,p_opcg1_f_o_a01)=0.0 if (p_ant1_c_a01.gt.1) chem(i,k,j,p_ant1_c_a01)=0.0 if (p_biog1_c_a01.gt.1) chem(i,k,j,p_biog1_c_a01)=0.0 - + if (p_pcg1_b_c_a02.gt.1) chem(i,k,j,p_pcg1_b_c_a02)=0.0 if (p_pcg1_b_o_a02.gt.1) chem(i,k,j,p_pcg1_b_o_a02)=0.0 if (p_opcg1_b_c_a02.gt.1) chem(i,k,j,p_opcg1_b_c_a02)=0.0 @@ -1432,7 +1439,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a02.gt.1) chem(i,k,j,p_opcg1_f_o_a02)=0.0 if (p_ant1_c_a02.gt.1) chem(i,k,j,p_ant1_c_a02)=0.0 if (p_biog1_c_a02.gt.1) chem(i,k,j,p_biog1_c_a02)=0.0 - + if (p_pcg1_b_c_a03.gt.1) chem(i,k,j,p_pcg1_b_c_a03)=0.0 if (p_pcg1_b_o_a03.gt.1) chem(i,k,j,p_pcg1_b_o_a03)=0.0 if (p_opcg1_b_c_a03.gt.1) chem(i,k,j,p_opcg1_b_c_a03)=0.0 @@ -1443,7 +1450,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a03.gt.1) chem(i,k,j,p_opcg1_f_o_a03)=0.0 if (p_ant1_c_a03.gt.1) chem(i,k,j,p_ant1_c_a03)=0.0 if (p_biog1_c_a03.gt.1) chem(i,k,j,p_biog1_c_a03)=0.0 - + if (p_pcg1_b_c_a04.gt.1) chem(i,k,j,p_pcg1_b_c_a04)=0.0 if (p_pcg1_b_o_a04.gt.1) chem(i,k,j,p_pcg1_b_o_a04)=0.0 if (p_opcg1_b_c_a04.gt.1) chem(i,k,j,p_opcg1_b_c_a04)=0.0 @@ -1454,7 +1461,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a04.gt.1) chem(i,k,j,p_opcg1_f_o_a04)=0.0 if (p_ant1_c_a04.gt.1) chem(i,k,j,p_ant1_c_a04)=0.0 if (p_biog1_c_a04.gt.1) chem(i,k,j,p_biog1_c_a04)=0.0 - + if (p_pcg1_b_c_a05.gt.1) chem(i,k,j,p_pcg1_b_c_a05)=0.0 if (p_pcg1_b_o_a05.gt.1) chem(i,k,j,p_pcg1_b_o_a05)=0.0 if (p_opcg1_b_c_a05.gt.1) chem(i,k,j,p_opcg1_b_c_a05)=0.0 @@ -1465,7 +1472,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a05.gt.1) chem(i,k,j,p_opcg1_f_o_a05)=0.0 if (p_ant1_c_a05.gt.1) chem(i,k,j,p_ant1_c_a05)=0.0 if (p_biog1_c_a05.gt.1) chem(i,k,j,p_biog1_c_a05)=0.0 - + if (p_pcg1_b_c_a06.gt.1) chem(i,k,j,p_pcg1_b_c_a06)=0.0 if (p_pcg1_b_o_a06.gt.1) chem(i,k,j,p_pcg1_b_o_a06)=0.0 if (p_opcg1_b_c_a06.gt.1) chem(i,k,j,p_opcg1_b_c_a06)=0.0 @@ -1476,7 +1483,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a06.gt.1) chem(i,k,j,p_opcg1_f_o_a06)=0.0 if (p_ant1_c_a06.gt.1) chem(i,k,j,p_ant1_c_a06)=0.0 if (p_biog1_c_a06.gt.1) chem(i,k,j,p_biog1_c_a06)=0.0 - + if (p_pcg1_b_c_a07.gt.1) chem(i,k,j,p_pcg1_b_c_a07)=0.0 if (p_pcg1_b_o_a07.gt.1) chem(i,k,j,p_pcg1_b_o_a07)=0.0 if (p_opcg1_b_c_a07.gt.1) chem(i,k,j,p_opcg1_b_c_a07)=0.0 @@ -1487,7 +1494,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a07.gt.1) chem(i,k,j,p_opcg1_f_o_a07)=0.0 if (p_ant1_c_a07.gt.1) chem(i,k,j,p_ant1_c_a07)=0.0 if (p_biog1_c_a07.gt.1) chem(i,k,j,p_biog1_c_a07)=0.0 - + if (p_pcg1_b_c_a08.gt.1) chem(i,k,j,p_pcg1_b_c_a08)=0.0 if (p_pcg1_b_o_a08.gt.1) chem(i,k,j,p_pcg1_b_o_a08)=0.0 if (p_opcg1_b_c_a08.gt.1) chem(i,k,j,p_opcg1_b_c_a08)=0.0 @@ -1498,9 +1505,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_a08.gt.1) chem(i,k,j,p_opcg1_f_o_a08)=0.0 if (p_ant1_c_a08.gt.1) chem(i,k,j,p_ant1_c_a08)=0.0 if (p_biog1_c_a08.gt.1) chem(i,k,j,p_biog1_c_a08)=0.0 - - - + + + if (p_pcg1_b_c_cw01.gt.1) chem(i,k,j,p_pcg1_b_c_cw01)=0.0 if (p_pcg1_b_o_cw01.gt.1) chem(i,k,j,p_pcg1_b_o_cw01)=0.0 if (p_opcg1_b_c_cw01.gt.1) chem(i,k,j,p_opcg1_b_c_cw01)=0.0 @@ -1511,7 +1518,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw01.gt.1) chem(i,k,j,p_opcg1_f_o_cw01)=0.0 if (p_ant1_c_cw01.gt.1) chem(i,k,j,p_ant1_c_cw01)=0.0 if (p_biog1_c_cw01.gt.1) chem(i,k,j,p_biog1_c_cw01)=0.0 - + if (p_pcg1_b_c_cw02.gt.1) chem(i,k,j,p_pcg1_b_c_cw02)=0.0 if (p_pcg1_b_o_cw02.gt.1) chem(i,k,j,p_pcg1_b_o_cw02)=0.0 if (p_opcg1_b_c_cw02.gt.1) chem(i,k,j,p_opcg1_b_c_cw02)=0.0 @@ -1522,7 +1529,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw02.gt.1) chem(i,k,j,p_opcg1_f_o_cw02)=0.0 if (p_ant1_c_cw02.gt.1) chem(i,k,j,p_ant1_c_cw02)=0.0 if (p_biog1_c_cw02.gt.1) chem(i,k,j,p_biog1_c_cw02)=0.0 - + if (p_pcg1_b_c_cw03.gt.1) chem(i,k,j,p_pcg1_b_c_cw03)=0.0 if (p_pcg1_b_o_cw03.gt.1) chem(i,k,j,p_pcg1_b_o_cw03)=0.0 if (p_opcg1_b_c_cw03.gt.1) chem(i,k,j,p_opcg1_b_c_cw03)=0.0 @@ -1533,7 +1540,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw03.gt.1) chem(i,k,j,p_opcg1_f_o_cw03)=0.0 if (p_ant1_c_cw03.gt.1) chem(i,k,j,p_ant1_c_cw03)=0.0 if (p_biog1_c_cw03.gt.1) chem(i,k,j,p_biog1_c_cw03)=0.0 - + if (p_pcg1_b_c_cw04.gt.1) chem(i,k,j,p_pcg1_b_c_cw04)=0.0 if (p_pcg1_b_o_cw04.gt.1) chem(i,k,j,p_pcg1_b_o_cw04)=0.0 if (p_opcg1_b_c_cw04.gt.1) chem(i,k,j,p_opcg1_b_c_cw04)=0.0 @@ -1544,7 +1551,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw04.gt.1) chem(i,k,j,p_opcg1_f_o_cw04)=0.0 if (p_ant1_c_cw04.gt.1) chem(i,k,j,p_ant1_c_cw04)=0.0 if (p_biog1_c_cw04.gt.1) chem(i,k,j,p_biog1_c_cw04)=0.0 - + if (p_pcg1_b_c_cw05.gt.1) chem(i,k,j,p_pcg1_b_c_cw05)=0.0 if (p_pcg1_b_o_cw05.gt.1) chem(i,k,j,p_pcg1_b_o_cw05)=0.0 if (p_opcg1_b_c_cw05.gt.1) chem(i,k,j,p_opcg1_b_c_cw05)=0.0 @@ -1555,7 +1562,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw05.gt.1) chem(i,k,j,p_opcg1_f_o_cw05)=0.0 if (p_ant1_c_cw05.gt.1) chem(i,k,j,p_ant1_c_cw05)=0.0 if (p_biog1_c_cw05.gt.1) chem(i,k,j,p_biog1_c_cw05)=0.0 - + if (p_pcg1_b_c_cw06.gt.1) chem(i,k,j,p_pcg1_b_c_cw06)=0.0 if (p_pcg1_b_o_cw06.gt.1) chem(i,k,j,p_pcg1_b_o_cw06)=0.0 if (p_opcg1_b_c_cw06.gt.1) chem(i,k,j,p_opcg1_b_c_cw06)=0.0 @@ -1566,7 +1573,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw06.gt.1) chem(i,k,j,p_opcg1_f_o_cw06)=0.0 if (p_ant1_c_cw06.gt.1) chem(i,k,j,p_ant1_c_cw06)=0.0 if (p_biog1_c_cw06.gt.1) chem(i,k,j,p_biog1_c_cw06)=0.0 - + if (p_pcg1_b_c_cw07.gt.1) chem(i,k,j,p_pcg1_b_c_cw07)=0.0 if (p_pcg1_b_o_cw07.gt.1) chem(i,k,j,p_pcg1_b_o_cw07)=0.0 if (p_opcg1_b_c_cw07.gt.1) chem(i,k,j,p_opcg1_b_c_cw07)=0.0 @@ -1577,7 +1584,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_opcg1_f_o_cw07.gt.1) chem(i,k,j,p_opcg1_f_o_cw07)=0.0 if (p_ant1_c_cw07.gt.1) chem(i,k,j,p_ant1_c_cw07)=0.0 if (p_biog1_c_cw07.gt.1) chem(i,k,j,p_biog1_c_cw07)=0.0 - + if (p_pcg1_b_c_cw08.gt.1) chem(i,k,j,p_pcg1_b_c_cw08)=0.0 if (p_pcg1_b_o_cw08.gt.1) chem(i,k,j,p_pcg1_b_o_cw08)=0.0 if (p_opcg1_b_c_cw08.gt.1) chem(i,k,j,p_opcg1_b_c_cw08)=0.0 @@ -1611,7 +1618,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ids,ide,jds,jde,kds,kde,its,ite,jts,jte,kts,kte) ENDIF - + !! Initialize some greenhouse gas species for 16th and 17th chemistry options: !! CO2 mixing ratios for the background GHG tracers are set as a constant value. !! Some spin-up is necessary to get spatial variability right! @@ -1776,7 +1783,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, gmtp=mod(xhour,24.) gmtp=gmtp+xmin/60. CALL szangle(1, 1, julday, gmtp, sza, cosszax,xlonn,rlat) - TCOSZ(i,j)=TCOSZ(I,J)+cosszax(1,1) + TCOSZ(i,j)=TCOSZ(I,J)+cosszax(1,1) if(cosszax(1,1).gt.0.)ttday(i,j)=ttday(i,j)+dt enddo ! if(i.eq.19.and.j.eq.19)write(0,*)'in cheminit' @@ -1847,7 +1854,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif endif chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) - CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP,RACM_SOA_VBS_HET_KPP) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') call aerosols_soa_vbs_init(chem,convfac,z_at_w, & @@ -1859,8 +1866,37 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, !!!TUCCELLA (BUG, before it was called in module_aerosols_soa_vbs.F) ! initialize pointers used by aerosol-cloud-interaction routines - call aerosols_soa_vbs_init_aercld_ptrs( & - num_chem, is_aerosol, config_flags ) + call aerosols_soa_vbs_init_aercld_ptrs(num_chem, is_aerosol, config_flags ) + +!...Convert aerosols to mixing ratio + if( .NOT. config_flags%restart ) then + if(config_flags%chem_in_opt == 0 .and. num_chem.gt.numgas)then + do l=numgas+1,num_chem + do j=jts,jte + do k=kts,kte + kk = min(k,kde-1) + do i=its,ite + chem(i,k,j,l)=chem(i,kk,j,l)*alt(i,kk,j) + enddo + enddo + enddo + enddo + endif + endif + chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) + CASE (RACM_SOA_VBS_HET_KPP) + CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') + + call aerosols_soa_vbs_het_init(chem,convfac,z_at_w, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + chem_in_opt,config_flags%aer_ic_opt,is_aerosol, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, config_flags ) + +!!!TUCCELLA (BUG, before it was called in module_aerosols_soa_vbs.F) + ! initialize pointers used by aerosol-cloud-interaction routines + call aerosols_soa_vbs_init_aercld_ptrs(num_chem, is_aerosol, config_flags ) !...Convert aerosols to mixing ratio if( .NOT. config_flags%restart ) then diff --git a/chem/emissions_driver.F b/chem/emissions_driver.F index 9c4c8cb1a8..47b1e6f4b2 100644 --- a/chem/emissions_driver.F +++ b/chem/emissions_driver.F @@ -70,10 +70,15 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ! stuff for aircraft emissions emis_aircraft, & ! stuff for GHG fluxes - vprm_in,rad_vprm,lambda_vprm,alpha_vprm,resp_vprm, & + vprm_in,rad_vprm,lambda_vprm,alpha_vprm,resp_vprm, & xtime,tslb,wet_in,rainc,rainnc,potevp,sfcevp,lu_index, & biomt_par,emit_par,ebio_co2oce,eghg_bio, & seas_flux, & + ! stuff for online nh3 "WRF-NH3-CHEM" modified by renchuanhua + actnh3,EFnh3, & + agrisoil_nh3, fertilizer_nh3, freeinten_nh3, graze_nh3, & + industry_nh3, residential_nh3, & + transport_nh3, current_hour, Q2, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -131,7 +136,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & REAL, DIMENSION( ims:ime, jms:jme, ne_area ), & INTENT(INOUT ) :: e_bio REAL, DIMENSION( ims:ime, 1:config_flags%kemit, jms:jme,num_emis_ant),& - INTENT(IN ) :: & + INTENT(INOUT ) :: & emis_ant REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_emis_vol), & INTENT(INOUT ) :: & @@ -290,7 +295,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & real, dimension (ims:ime, jms:jme ) , & intent(in) :: & - T2, swdown + T2, swdown, Q2 ! modifed by renchuanhua integer, intent(in) :: current_month @@ -336,7 +341,53 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: ht, ic_flashrate, cg_flashrate REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: refl_10cm ! end stuff for lightning NOx -! + +! stuff for online NH3 "WRF-NH3-CHEM" modified by renchuanhua + REAL, DIMENSION( ims:ime,12,jms:jme ), OPTIONAL, INTENT(IN ) :: actnh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: EFnh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: agrisoil_nh3 + REAL, DIMENSION( ims:ime,12,jms:jme ), OPTIONAL, INTENT(INOUT ) :: fertilizer_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: freeinten_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: graze_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: industry_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: residential_nh3 + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT ) :: transport_nh3 + INTEGER, INTENT(IN ) :: current_hour + + + ! local variables + real,parameter :: EFstd =5.5 + real :: CFwind,CFtemp,CFsmois_hus,CFrain + integer :: h + real, dimension (ims:ime, jms:jme ) :: frin_house, frin_sManure,frin_manureStore !renchuanhua + real, dimension (ims:ime, jms:jme ) :: graze_house, graze_out + real, dimension (ims:ime, jms:jme ) :: CFsmois + real, dimension (ims:ime, jms:jme ) :: T_house, V_house, GF_Thouse + real, parameter :: Factor_fihouse=0.156, Factor_sManure=0.774, Factor_manureStore=0.07 + real, parameter :: Factor_grhouse=0.226 + + real, dimension (ims:ime, jms:jme ) :: house, store ,outsoil + real, dimension (ims:ime, jms:jme ) :: emis_house, emis_store ,emis_fert + +real, save :: freq_residential(24) = & + (/0.0110, 0.0030, 0.0010, 0.0000, 0.0020, 0.0169, & + 0.0914, 0.2111, 0.1402, 0.0905, 0.0676, 0.0487, & + 0.0179, 0.0358, 0.0258, 0.0182, 0.0272, 0.0222, & + 0.0411, 0.0401, 0.0268, 0.0202, 0.0212, 0.0202/) +real, save :: freq_transport(24) = & + (/0.02, 0.01, 0.01, 0.00, 0.00, 0.00, & + 0.01, 0.03, 0.06, 0.06, 0.06, 0.05, & + 0.06, 0.06, 0.06, 0.07, 0.07, 0.08, & + 0.08, 0.07, 0.05, 0.04, 0.03, 0.02/) +real, save :: freq_industry(24) = & + (/0.02, 0.01, 0.01, 0.00, 0.00, 0.00, & + 0.01, 0.03, 0.06, 0.06, 0.06, 0.05, & + 0.06, 0.06, 0.06, 0.07, 0.07, 0.08, & + 0.08, 0.07, 0.05, 0.04, 0.03, 0.02/) + +! end stuff online NH3 + + ! Local variables... ! INTEGER :: begday,endday,i, j, k, m, p_in_chem, ksub, dust_emiss_active, seasalt_emiss_active,emiss_ash_hgt @@ -951,6 +1002,76 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & END SELECT bioem_select !!! **************** END BIOGENICS, ADD EMISSIONS FOR VARIOUS PACKAGES + + +!!! online nh3 "WRF-NH3-CHEM" modified by renchuanhua + + if( config_flags%nh3emis_opt == ONLINE) then + emis_ant(ims:ime , config_flags%kemit , jms:jme, p_e_nh3)=0.0 + + frin_house = freeinten_nh3*Factor_fihouse ! house [in] + frin_sManure = freeinten_nh3*Factor_sManure ! manure - field [out] + frin_manureStore = freeinten_nh3*Factor_manureStore ! manure - store [none] + graze_house = graze_nh3*Factor_grhouse ! graze [in] + graze_out = graze_nh3*(1.0-Factor_grhouse) ! graze [out] + + GF_Thouse =1.0 + +! Animal house temperature and wind speed + where( T2.LT.273.15) + T_house = 287.15 + 0.5*(T2-(273.15+0)) + V_house = 0.2 + elsewhere(T2 .GE. 273.15 .and. T2 .LT. 285.65) + T_house = 287.15 + V_house = 0.2 + T2*(0.405/12.5) + elsewhere(T2 .GE. 285.65) + T_house = 287.15 + 1.4*(T2-(285.65)) + V_house = 0.405 !0.5*(0.38+0.43) + end where + +! out field soil moisture correction factor + where( smois(:,1,:).LT.0.45) + CFsmois = 0.45*exp(-1.0*smois(:,1,:))+0.55 + elsewhere(smois(:,1,:).GE.0.45) + CFsmois = 0.45*exp(smois(:,1,:))+0.6 + end where + + + do j=jts,jte + do i=its,ite + + + CFwind =exp(0.0419*(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))**0.5) + CFtemp = (exp(0.093*(tsk(i,j)-T2(i,j))-0.57))*exp(0.018*(tsk(i,j)-273.15)) + CFrain = 1/(3.2*rainnc(i,j)+1.0) + EFnh3(i,j)=CFsmois(i,j)*CFtemp*CFrain*CFwind + + CFsmois_hus = 0.45*exp(-1.0*smois(i,1,j))+0.55 + GF_Thouse =exp((0.093*(T_house(i,j)-tsk(i,j)))-0.57)*exp(0.018*(tsk(i,j)-273.15)) + + ! for house + emis_house(i,j) = CFsmois_hus*GF_Thouse(i,j)*exp(0.0419*V_house(i,j))*(frin_house(i,j) + graze_house(i,j)) + ! for store + emis_store(i,j) = frin_manureStore(i,j) + ! for outside soil + emis_fert(i,j) = EFnh3(i,j)*(fertilizer_nh3(i,current_month,j)+frin_sManure(i,j)+ graze_out(i,j)+agrisoil_nh3(i,j)) + + +! fertilizer and freeinten .... units is kg/km2/month +! conv is used to change units from "mole/km2/hr" to "delta ppmv" + conv = 4.828e-4/rho_phy(i,1,j)*dtstep/(dz8w(i,1,j)*60.) + h=MOD(current_hour+8,24) !range 0-23 + + emis_ant(i,1,j,p_e_nh3)=1000.0/(17.0*30.0*24.0)*(emis_house(i,j)+emis_store(i,j)+emis_fert(i,j)) & + + freq_residential(h+1)*residential_nh3(i,j)*1000.0/(30.0*17.0) & + + freq_industry(h+1) *industry_nh3(i,j)*1000.0/(30.0*17.0) & + + freq_transport(h+1) *transport_nh3(i,j)*1000.0/(30.0*17.0) + enddo + enddo + + end if + + ! gas_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & diff --git a/chem/module_aerosols_soa_vbs_het.F b/chem/module_aerosols_soa_vbs_het.F index ca7c90059e..5a3e0d2019 100644 --- a/chem/module_aerosols_soa_vbs_het.F +++ b/chem/module_aerosols_soa_vbs_het.F @@ -6593,7 +6593,7 @@ SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, & END SUBROUTINE VDVG_2 !------------------------------------------------------------------------------ -SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, & +SUBROUTINE aerosols_soa_vbs_het_init(chem,convfac,z_at_w, & pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & chem_in_opt,aer_ic_opt, is_aerosol, & ids,ide, jds,jde, kds,kde, & @@ -6812,7 +6812,7 @@ SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, ! chem, zz, i,k,j, ims,ime,jms,jme,kms,kme ) else call wrf_error_fatal( & - "aerosols_soa_vbs_init: unable to parse aer_ic_opt" ) + "aerosols_soa_vbs_het_init: unable to parse aer_ic_opt" ) end if !... i-mode @@ -6861,7 +6861,7 @@ SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, enddo return - END SUBROUTINE aerosols_soa_vbs_init + END SUBROUTINE aerosols_soa_vbs_het_init ! SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & diff --git a/clean b/clean index 6ce8142cd6..2fd6453194 100755 --- a/clean +++ b/clean @@ -3,12 +3,12 @@ set nonomatch -foreach dir ( frame chem share dyn_em phys cmaq main tools wrftladj ) +foreach dir ( frame chem share dyn_em phys phys/physics_mmm cmaq main tools wrftladj ) if ( -d $dir ) then if ( $dir == cmaq ) then ( cd $dir ; echo $dir ; /bin/rm -f *.o *.mod ) >& /dev/null else - ( cd $dir ; echo $dir ; /bin/rm -f core wrf *.f90 *.exe *.kmo *.mod *.o *.obj *.inc *.F90 *.a \ + ( cd $dir ; echo $dir ; /bin/rm -f core wrf *.f90 *.exe *.kmo *.mod *.o *.obj *.inc *.a \ db_* Warnings module_state_description.F module_dm.F gmeta \ wrfdata whatiread rsl.* show_domain* ) >& /dev/null endif diff --git a/cleanCMake.sh b/cleanCMake.sh new file mode 100755 index 0000000000..06c3a38a8c --- /dev/null +++ b/cleanCMake.sh @@ -0,0 +1,69 @@ +#!/bin/sh +buildDirectory=_build +installDirectory=install + +help() +{ + echo "./cleanCMake.sh [options]" + echo " -c [Default if no options] Basic cmake clean functionality [make -j 1 clean]" + echo " -b Remove cmake binary installs [xargs rm < ${buildDirectory}/install_manifest.txt]" + echo " -f Remove build & install folders (WRF) [ rm ${buildDirectory} -r; rm ${installDirectory}/ -r ]" + echo " -a Remove all (WRF), equivalent to -c -b -f (more specifically -c then -b then-f)" + echo "Specific builds/installs" + echo " -d directory Specify operating on particular build directory" + echo " -i directory Specify operating on particular install directory" +} + +cleanBasicBuild=FALSE +cleanBasicInstall=FALSE +cleanLinks=FALSE +cleanFolders=FALSE +cleanAll=FALSE + +while getopts "hcbfad:i:" opt; do + case ${opt} in + c) + cleanBasicBuild=TRUE + ;; + b) + cleanBasicInstall=TRUE + ;; + f) + cleanFolders=TRUE + ;; + a) + cleanAll=TRUE + ;; + d) + buildDirectory=$OPTARG + ;; + i) + installDirectory=$OPTARG + ;; + h) help; exit 0 ;; + *) help; exit 1 ;; + :) help; exit 1 ;; + \?) help; exit 1 ;; + esac +done + +if [ $OPTIND -eq 1 ]; then + # Do basic clean I guess + cleanBasicBuild=TRUE +fi + +if [ "${cleanBasicBuild}" = "TRUE" ] || [ "${cleanAll}" = "TRUE" ]; then + echo "Doing cmake make clean" + OLD_DIR=$PWD + cd ${buildDirectory} && make -j 1 clean > /dev/null 2>&1; cd $OLD_DIR +fi + +if [ "${cleanBasicInstall}" = "TRUE" ] || [ "${cleanAll}" = "TRUE" ]; then + echo "Removing binary installs" + xargs rm < ${buildDirectory}/install_manifest.txt > /dev/null 2>&1 +fi + +if [ "${cleanFolders}" = "TRUE" ] || [ "${cleanAll}" = "TRUE" ]; then + echo "Deleting ${buildDirectory} & ${installDirectory}/" + rm ${buildDirectory} -r; rm ${installDirectory}/ -r > /dev/null 2>&1 +fi diff --git a/cmake/c_preproc.cmake b/cmake/c_preproc.cmake new file mode 100644 index 0000000000..14f7fe9295 --- /dev/null +++ b/cmake/c_preproc.cmake @@ -0,0 +1,130 @@ +# WRF Macro for C preprocessing F files that are just... bad ifdef usage to say the least +macro( wrf_c_preproc_fortran ) + + set( options ) + set( oneValueArgs TARGET_NAME SUFFIX PREFIX EXTENSION OUTPUT_DIR ) + set( multiValueArgs DEPENDENCIES INCLUDES SOURCES DEFINITIONS TARGET_SCOPE ) + + cmake_parse_arguments( + WRF_PP_F + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + + # Santitize input + if ( DEFINED WRF_PP_F_TARGET_SCOPE ) + set( WRF_PP_F_TARGET_DIRECTORY TARGET_DIRECTORY ${WRF_PP_F_TARGET_SCOPE} ) + endif() + + set( WRF_PP_F_INCLUDES_FLAGS ) + foreach( WRF_PP_F_INC ${WRF_PP_F_INCLUDES} ) + list( APPEND WRF_PP_F_INCLUDES_FLAGS -I${WRF_PP_F_INC} ) + endforeach() + + wrf_expand_definitions( + RESULT_VAR WRF_PP_F_DEFS + DEFINITIONS ${WRF_PP_F_DEFINITIONS} + ) + + # Generate compile command and file outputs + set( WRF_PP_F_OUTPUT ) + set( WRF_PP_F_COMMANDS ) + foreach( WRF_PP_F_SOURCE_FILE ${WRF_PP_F_SOURCES} ) + get_filename_component( WRF_PP_F_INPUT_SOURCE ${WRF_PP_F_SOURCE_FILE} REALPATH ) + get_filename_component( WRF_PP_F_INPUT_SOURCE_FILE_ONLY ${WRF_PP_F_SOURCE_FILE} NAME ) + + if ( ${WRF_PP_F_EXTENSION} MATCHES "^[.][a-z0-9]+$" ) + string( REGEX REPLACE "[.].*$" "${WRF_PP_F_EXTENSION}" WRF_PP_F_OUTPUT_FILE ${WRF_PP_F_INPUT_SOURCE_FILE_ONLY} ) + else() + # Default extension + string( REGEX REPLACE "[.].*$" ".i" WRF_PP_F_OUTPUT_FILE ${WRF_PP_F_INPUT_SOURCE_FILE_ONLY} ) + endif() + + set( WRF_PP_F_OUTPUT_FILE ${WRF_PP_F_OUTPUT_DIR}/${WRF_PP_F_PREFIX}${WRF_PP_F_OUTPUT_FILE}${WRF_PP_F_SUFFIX} ) + + list( + APPEND WRF_PP_F_COMMANDS + COMMAND ${CMAKE_C_PREPROCESSOR} ${CMAKE_C_PREPROCESSOR_FLAGS} ${WRF_PP_F_INPUT_SOURCE} ${WRF_PP_F_DEFS} ${WRF_PP_F_INCLUDES_FLAGS} > ${WRF_PP_F_OUTPUT_FILE} + # Force check that they were made + COMMAND ${CMAKE_COMMAND} -E compare_files ${WRF_PP_F_OUTPUT_FILE} ${WRF_PP_F_OUTPUT_FILE} + ) + list( + APPEND WRF_PP_F_OUTPUT + ${WRF_PP_F_OUTPUT_FILE} + ) + + # # Tell all targets that eventually use this file that it is generated - this is useful if this macro is used in a + # # different directory than where the target dependency is set + # # Thanks to https://gitlab.kitware.com/cmake/community/-/wikis/FAQ#how-can-i-add-a-dependency-to-a-source-file-which-is-generated-in-a-subdirectory + # # and https://samthursfield.wordpress.com/2015/11/21/cmake-dependencies-between-targets-and-files-and-custom-commands/ + # # It keeps getting better lol + # # https://gitlab.kitware.com/cmake/cmake/-/issues/18399 + # # We could use cmake 3.20+ and CMP0118, but this allows usage from 3.18.6+ + # TL;DR - This doesn't work despite all documentation stating otherwise, need to use CMP0118 + # set_source_files_properties( + # ${WRF_PP_F_OUTPUT_FILE} + # ${WRF_PP_F_TARGET_DIRECTORY} + # PROPERTIES + # GENERATED TRUE + # ) + set_source_files_properties( + ${WRF_PP_F_OUTPUT_FILE} + DIRECTORY ${PROJECT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR} + ${WRF_PP_F_TARGET_DIRECTORY} + PROPERTIES + Fortran_PREPROCESS OFF + ) + # message( STATUS "File ${WRF_PP_F_SOURCE_FILE} will be preprocessed into ${WRF_PP_F_OUTPUT_FILE}" ) + + endforeach() + + # Preprocess sources into a custom target + add_custom_command( + OUTPUT ${WRF_PP_F_OUTPUT} + COMMAND ${CMAKE_COMMAND} -E make_directory ${WRF_PP_F_OUTPUT_DIR} + ${WRF_PP_F_COMMANDS} + COMMENT "Preprocessing ${WRF_PP_F_TARGET_NAME}" + DEPENDS ${WRF_PP_F_DEPENDENCIES} + ) + + add_custom_target( + ${WRF_PP_F_TARGET_NAME} + COMMENT "Building ${WRF_PP_F_TARGET_NAME}" + DEPENDS ${WRF_PP_F_OUTPUT} + ) + +endmacro() + +# Helper macro to take current defintions and santize them with -D, compatible with generator expressions +# for use when definitions are needed at generation time for custom commands +macro( wrf_expand_definitions ) + set( options ) + set( oneValueArgs RESULT_VAR ) + set( multiValueArgs DEFINITIONS ) + + cmake_parse_arguments( + WRF_EXP + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + + set( WRF_EXP_DEFS ) + foreach( WRF_EXP_DEF ${WRF_EXP_DEFINITIONS} ) + if ( NOT ${WRF_EXP_DEF} MATCHES ".*-D.*" ) + # We have a generator expression, inject the -D correctly + # THIS SHOULD ONLY BE USED FOR CONDITIONALLY APPLIED DEFINITIONS + if ( ${WRF_EXP_DEF} MATCHES "^[$]<" ) + # Take advantage of the fact that a define is most likely not an expanded variable (i.e. starts with a-zA-Z, adjust if not) + # preceeded by the defining generator expression syntax $<>:var or ,var + # Yes this is fragile but is probably more robust than the current code if you're relying on this macro :D + string( REGEX REPLACE "(>:|,)([a-zA-Z])" "\\1-D\\2" WRF_EXP_DEF_SANITIZED ${WRF_EXP_DEF} ) + list( APPEND WRF_EXP_DEFS ${WRF_EXP_DEF_SANITIZED} ) + else() + list( APPEND WRF_EXP_DEFS -D${WRF_EXP_DEF} ) + endif() + endif() + + endforeach() + + set( ${WRF_EXP_RESULT_VAR} ${WRF_EXP_DEFS} ) +endmacro() \ No newline at end of file diff --git a/cmake/confcheck.cmake b/cmake/confcheck.cmake new file mode 100644 index 0000000000..5db8469519 --- /dev/null +++ b/cmake/confcheck.cmake @@ -0,0 +1,133 @@ +# WRF Macro for adding configuration checks from source file, default is fortran +# https://cmake.org/cmake/help/latest/module/CheckFortranSourceCompiles.html +# https://github.com/ufs-community/ufs-weather-model/issues/132 +include( CheckFortranSourceRuns ) +include( CheckFortranSourceCompiles ) +include( CheckCSourceRuns ) +include( CheckCSourceCompiles ) +include( CheckCXXSourceRuns ) +include( CheckCXXSourceCompiles ) + +macro( wrf_conf_check ) + + set( options QUIET RUN REQUIRED ) + set( oneValueArgs RESULT_VAR EXTENSION FAIL_REGEX SOURCE MESSAGE SOURCE_TYPE ) + set( multiValueArgs ADDITIONAL_FLAGS ADDITIONAL_DEFINITIONS ADDITIONAL_INCLUDES ADDITIONAL_LINK_OPTIONS ADDITIONAL_LIBRARIES ) + + cmake_parse_arguments( + WRF_CFG + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + + get_filename_component( WRF_CFG_SOURCE_FILE ${WRF_CFG_SOURCE} REALPATH ) + file( READ ${WRF_CFG_SOURCE_FILE} WRF_CFG_CODE ) + + # Santize for newlines + string( REPLACE "\\n" "\\\\n" WRF_CFG_CODE "${WRF_CFG_CODE}" ) + + if ( NOT DEFINED WRF_CFG_SOURCE_TYPE ) + set( WRF_CFG_SOURCE_TYPE fortran ) + endif() + + if ( DEFINED WRF_CFG_FAIL_REGEX ) + if ( DEFINED WRF_CFG_RUN ) + message( WARNING "wrf_conf_check: FAIL_REGEX ignored when running check" ) + else() + set( WRF_CFG_FAIL_REGEX FAIL_REGEX ${WRF_CFG_FAIL_REGEX} ) + endif() + endif() + + if ( DEFINED WRF_CFG_EXTENSION ) + set( WRF_CFG_EXTENSION SRC_EXT ${WRF_CFG_EXTENSION} ) + endif() + + # Additional options + if ( DEFINED WRF_CFG_QUIET AND ${WRF_CFG_QUIET} ) + set( CMAKE_REQUIRED_QUIET ${WRF_CFG_QUIET} ) + endif() + + if ( DEFINED WRF_CFG_ADDITIONAL_FLAGS ) + set( CMAKE_REQUIRED_FLAGS ${WRF_CFG_ADDITIONAL_FLAGS} ) + endif() + + if ( DEFINED WRF_CFG_ADDITIONAL_DEFINITIONS ) + set( CMAKE_REQUIRED_DEFINITIONS ${WRF_CFG_ADDITIONAL_DEFINITIONS} ) + endif() + + if ( DEFINED WRF_CFG_ADDITIONAL_INCLUDES ) + set( CMAKE_REQUIRED_INCLUDES ${WRF_CFG_ADDITIONAL_INCLUDES} ) + endif() + + if ( DEFINED WRF_CFG_ADDITIONAL_LINK_OPTIONS ) + set( CMAKE_REQUIRED_LINK_OPTIONS ${WRF_CFG_ADDITIONAL_LINK_OPTIONS} ) + endif() + + if ( DEFINED WRF_CFG_ADDITIONAL_LIBRARIES ) + set( CMAKE_REQUIRED_LIBRARIES ${WRF_CFG_ADDITIONAL_LIBRARIES} ) + endif() + + string( TOLOWER "${WRF_CFG_SOURCE_TYPE}" WRF_CFG_SOURCE_TYPE ) + if ( DEFINED WRF_CFG_RUN ) + if ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "fortran" ) + check_fortran_source_runs( + "${WRF_CFG_CODE}" + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_FAIL_REGEX} + ${WRF_CFG_EXTENSION} + ) + elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "c" ) + check_c_source_runs( + "${WRF_CFG_CODE}" + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_FAIL_REGEX} + ${WRF_CFG_EXTENSION} + ) + elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "cpp" ) + check_cpp_source_runs( + "${WRF_CFG_CODE}" + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_FAIL_REGEX} + ${WRF_CFG_EXTENSION} + ) + endif() + else() + if ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "fortran" ) + check_fortran_source_compiles( + "${WRF_CFG_CODE}" + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_EXTENSION} + ) + elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "c" ) + check_c_source_compiles( + "${WRF_CFG_CODE}" + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_EXTENSION} + ) + elseif ( ${WRF_CFG_SOURCE_TYPE} STREQUAL "cpp" ) + check_cpp_source_compiles( + "${WRF_CFG_CODE}" + ${WRF_CFG_RESULT_VAR} + ${WRF_CFG_EXTENSION} + ) + endif() + endif() + + # If it failed - note that since this is a run/compile test we expect pass/true + # to just proceed as normal, but if failure we should do something about it + if ( NOT ( DEFINED ${WRF_CFG_RESULT_VAR} AND "${${WRF_CFG_RESULT_VAR}}" ) ) + set( WRF_CFG_MSG_TYPE STATUS ) + if ( DEFINED WRF_CFG_REQUIRED AND ${WRF_CFG_REQUIRED} ) + set( WRF_CFG_MSG_TYPE FATAL_ERROR ) + endif() + + if ( DEFINED WRF_CFG_MESSAGE ) + message( ${WRF_CFG_MSG_TYPE} "${WRF_CFG_MESSAGE}" ) + else() + message( ${WRF_CFG_MSG_TYPE} "${WRF_CFG_RESULT_VAR} marked as required, check failed" ) + endif() + endif() + +endmacro() + + diff --git a/cmake/gitinfo.cmake b/cmake/gitinfo.cmake new file mode 100644 index 0000000000..0262961c18 --- /dev/null +++ b/cmake/gitinfo.cmake @@ -0,0 +1,41 @@ +# WRF Macro to identify the commit where the compiled code came from +macro( wrf_git_commit ) + + set( options ) + set( oneValueArgs WORKING_DIRECTORY RESULT_VAR ) + set( multiValueArgs ) + + cmake_parse_arguments( + WRF_GIT_COMMIT + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + + + message( STATUS "Retrieving git information..." ) + execute_process( + OUTPUT_VARIABLE WRF_GIT_COMMIT_SHA + COMMAND git describe --dirty --long --always --abbrev=40 + WORKING_DIRECTORY ${WRF_GIT_COMMIT_WORKING_DIRECTORY} + RESULT_VARIABLE WRF_GIT_COMMIT_NO_GIT_REPO + # ECHO_OUTPUT_VARIABLE + OUTPUT_STRIP_TRAILING_WHITESPACE + ) + execute_process( + OUTPUT_VARIABLE WRF_GIT_COMMIT_DIFF + COMMAND git diff --shortstat + WORKING_DIRECTORY ${WRF_GIT_COMMIT_WORKING_DIRECTORY} + # ECHO_OUTPUT_VARIABLE + OUTPUT_STRIP_TRAILING_WHITESPACE + ) + + if ( ${WRF_GIT_COMMIT_NO_GIT_REPO} GREATER 0 ) + set( ${WRF_GIT_COMMIT_RESULT_VAR} "No git found or not a git repository, git commit version not available.") + message( STATUS "git info : Unable to get info" ) + else() + set( ${WRF_GIT_COMMIT_RESULT_VAR} "git info : ${WRF_GIT_COMMIT_SHA} ${WRF_GIT_COMMIT_DIFF}" ) + message( STATUS "git SHA : ${WRF_GIT_COMMIT_SHA}" ) + message( STATUS "git diff : ${WRF_GIT_COMMIT_DIFF}" ) + endif() + +endmacro() \ No newline at end of file diff --git a/cmake/m4_preproc.cmake b/cmake/m4_preproc.cmake new file mode 100644 index 0000000000..4158795578 --- /dev/null +++ b/cmake/m4_preproc.cmake @@ -0,0 +1,88 @@ +# WRF Macro for m4 preprocessing F files +macro( wrf_m4_preproc_fortran ) + + set( options ) + set( oneValueArgs TARGET_NAME SUFFIX PREFIX EXTENSION OUTPUT_DIR M4_PROGRAM ) + set( multiValueArgs DEPENDENCIES SOURCES FLAGS TARGET_SCOPE ) + + cmake_parse_arguments( + WRF_PP_M4 + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + set( WRF_PP_M4_PROGRAM_TO_USE m4 ) + if ( DEFINED WRF_PP_M4_PROGRAM ) + set( WRF_PP_M4_PROGRAM_TO_USE ${WRF_PP_M4_PROGRAM} ) + endif() + + # Santitize input + if ( DEFINED WRF_PP_M4_TARGET_SCOPE ) + set( WRF_PP_M4_TARGET_DIRECTORY TARGET_DIRECTORY ${WRF_PP_M4_TARGET_SCOPE} ) + endif() + + # Generate compile command and file outputs + set( WRF_PP_M4_OUTPUT ) + set( WRF_PP_M4_COMMANDS ) + foreach( WRF_PP_M4_SOURCE_FILE ${WRF_PP_M4_SOURCES} ) + get_filename_component( WRF_PP_M4_INPUT_SOURCE ${WRF_PP_M4_SOURCE_FILE} REALPATH ) + get_filename_component( WRF_PP_M4_INPUT_SOURCE_FILE_ONLY ${WRF_PP_M4_SOURCE_FILE} NAME ) + + if ( ${WRF_PP_M4_EXTENSION} MATCHES "^[.][a-z0-9]+$" ) + string( REGEX REPLACE "[.].*$" "${WRF_PP_M4_EXTENSION}" WRF_PP_M4_OUTPUT_FILE ${WRF_PP_M4_INPUT_SOURCE_FILE_ONLY} ) + else() + # Default extension + string( REGEX REPLACE "[.].*$" ".i" WRF_PP_M4_OUTPUT_FILE ${WRF_PP_M4_INPUT_SOURCE_FILE_ONLY} ) + endif() + + set( WRF_PP_M4_OUTPUT_FILE ${WRF_PP_M4_OUTPUT_DIR}/${WRF_PP_M4_PREFIX}${WRF_PP_M4_OUTPUT_FILE}${WRF_PP_M4_SUFFIX} ) + + list( + APPEND WRF_PP_M4_COMMANDS + COMMAND ${WRF_PP_M4_PROGRAM_TO_USE} ${WRF_PP_M4_FLAGS} ${WRF_PP_M4_INPUT_SOURCE} > ${WRF_PP_M4_OUTPUT_FILE} + # Force check that they were made + COMMAND ${CMAKE_COMMAND} -E compare_files ${WRF_PP_M4_OUTPUT_FILE} ${WRF_PP_M4_OUTPUT_FILE} + ) + list( + APPEND WRF_PP_M4_OUTPUT + ${WRF_PP_M4_OUTPUT_FILE} + ) + + # # Tell all targets that eventually use this file that it is generated - this is useful if this macro is used in a + # # different directory than where the target dependency is set + # # Thanks to https://gitlab.kitware.com/cmake/community/-/wikis/FAQ#how-can-i-add-a-dependency-to-a-source-file-which-is-generated-in-a-subdirectory + # # and https://samthursfield.wordpress.com/2015/11/21/cmake-dependencies-between-targets-and-files-and-custom-commands/ + # # It keeps getting better lol + # # https://gitlab.kitware.com/cmake/cmake/-/issues/18399 + # # We could use cmake 3.20+ and CMP0118, but this allows usage from 3.18.6+ + # TL;DR - This doesn't work despite all documentation stating otherwise, need to use CMP0118 + # set_source_files_properties( + # ${WRF_PP_M4_OUTPUT_FILE} + # ${WRF_PP_M4_TARGET_DIRECTORY} + # PROPERTIES + # GENERATED TRUE + # ) + set_source_files_properties( + ${WRF_PP_M4_OUTPUT_FILE} + DIRECTORY ${PROJECT_SOURCE_DIR} ${CMAKE_CURRENT_SOURCE_DIR} + ${WRF_PP_M4_TARGET_DIRECTORY} + PROPERTIES + Fortran_PREPROCESS OFF + ) + # message( STATUS "File ${WRF_PP_M4_SOURCE_FILE} will be preprocessed into ${WRF_PP_M4_OUTPUT_FILE}" ) + + endforeach() + + # Preprocess sources into a custom target + add_custom_command( + OUTPUT ${WRF_PP_M4_OUTPUT} + COMMAND ${CMAKE_COMMAND} -E make_directory ${WRF_PP_M4_OUTPUT_DIR} + ${WRF_PP_M4_COMMANDS} + COMMENT "Preprocessing ${WRF_PP_M4_TARGET_NAME}" + DEPENDS ${WRF_PP_M4_DEPENDENCIES} + ) + + add_custom_target( + ${WRF_PP_M4_TARGET_NAME} + DEPENDS ${WRF_PP_M4_OUTPUT} + ) +endmacro() diff --git a/cmake/modules/FindJasper.cmake b/cmake/modules/FindJasper.cmake new file mode 100644 index 0000000000..541ecf2147 --- /dev/null +++ b/cmake/modules/FindJasper.cmake @@ -0,0 +1,65 @@ +# Find Jasper +# Eventually replace with Jasper's actual config if using that +# Once found this file will define: +# Jasper_FOUND - System has Jasper +# Jasper_INCLUDE_DIRS - The Jasper include directories +# Jasper_LIBRARIES - The libraries needed to use Jasper + +find_package( PkgConfig ) +pkg_check_modules( PC_Jasper QUIET Jasper ) +# set(CMAKE_FIND_DEBUG_MODE TRUE) +find_path( + Jasper_INCLUDE_DIR + NAMES jasper/jasper.h # Make it so we go up one dir + # Hints before PATHS + HINTS ${Jasper_ROOT} ${JASPERINC} ${JASPER_PATH} ENV Jasper_ROOT ENV JASPERINC ENV JASPER_PATH + PATHS ${PC_Jasper_INCLUDE_DIRS} + PATH_SUFFIXES Jasper jasper include #include/jasper + ) +find_library( + Jasper_LIBRARY + NAMES jasper + # Hints before PATHS + HINTS ${Jasper_ROOT} ${JASPERLIB} ${JASPER_PATH} ENV Jasper_ROOT ENV JASPERLIB ENV JASPER_PATH + PATHS ${PC_Jasper_LIBRARY_DIRS} + PATH_SUFFIXES lib + ) + +# Ripped from https://github.com/Kitware/CMake/blob/master/Modules/FindJasper.cmake +if( Jasper_INCLUDE_DIR AND EXISTS "${Jasper_INCLUDE_DIR}/jasper/jas_config.h") + file(STRINGS "${Jasper_INCLUDE_DIR}/jasper/jas_config.h" jasper_version_str REGEX "^#define[\t ]+JAS_VERSION[\t ]+\".*\".*") + string(REGEX REPLACE "^#define[\t ]+JAS_VERSION[\t ]+\"([^\"]+)\".*" "\\1" Jasper_VERSION_STRING "${jasper_version_str}") +endif() +# set(CMAKE_FIND_DEBUG_MODE FALSE) + +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + Jasper + FOUND_VAR Jasper_FOUND + REQUIRED_VARS + Jasper_LIBRARY + Jasper_INCLUDE_DIR + VERSION_VAR Jasper_VERSION_STRING + HANDLE_VERSION_RANGE + ) + +if ( Jasper_FOUND AND NOT TARGET Jasper::Jasper ) + add_library( Jasper::Jasper UNKNOWN IMPORTED ) + set_target_properties( + Jasper::Jasper + PROPERTIES + IMPORTED_LOCATION "${Jasper_LIBRARY}" + INTERFACE_COMPILE_OPTIONS "${PC_Jasper_CFLAGS_OTHER}" + INTERFACE_INCLUDE_DIRECTORIES "${Jasper_INCLUDE_DIR}" + ) + + # Allow traditional/legacy style usage + set( Jasper_LIBRARIES ${Jasper_LIBRARY} ) + set( Jasper_INCLUDE_DIRS ${Jasper_INCLUDE_DIR} ) + set( Jasper_DEFINITIONS ${PC_Jasper_CFLAGS_OTHER} ) + + mark_as_advanced( + Jasper_INCLUDE_DIR + Jasper_LIBRARY + ) +endif() \ No newline at end of file diff --git a/cmake/modules/FindRPC.cmake b/cmake/modules/FindRPC.cmake new file mode 100644 index 0000000000..fbbbbda36f --- /dev/null +++ b/cmake/modules/FindRPC.cmake @@ -0,0 +1,59 @@ +# Find RPC +# Eventually replace with RPC's actual config if using that +# Once found this file will define: +# RPC_FOUND - System has RPC +# RPC_INCLUDE_DIRS - The RPC include directories +# RPC_LIBRARIES - The libraries needed to use RPC + +find_package( PkgConfig ) +pkg_check_modules( PC_RPC QUIET RPC ) +# set(CMAKE_FIND_DEBUG_MODE TRUE) +find_path( + RPC_INCLUDE_DIR + NAMES rpc/types.h # Make it so we go up one dir + # Hints before PATHS + HINTS ENV RPC_ROOT ENV RPCINC ENV RPC_PATH ${RPC_ROOT} ${RPCINC} ${RPC_PATH} + PATHS ${PC_RPC_INCLUDE_DIRS} + PATH_SUFFIXES tirpc + ) +find_library( + RPC_LIBRARY + NAMES rpc rpcsvc + # Hints before PATHS + HINTS ENV RPC_ROOT ENV RPCLIB ENV RPC_PATH ${RPC_ROOT} ${RPCLIB} ${RPC_PATH} + PATHS ${PC_RPC_LIBRARY_DIRS} + PATH_SUFFIXES lib + ) + +# set(CMAKE_FIND_DEBUG_MODE FALSE) + +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + RPC + FOUND_VAR RPC_FOUND + REQUIRED_VARS + RPC_LIBRARY + RPC_INCLUDE_DIR + # VERSION_VAR RPC_VERSION + ) + +if ( RPC_FOUND AND NOT TARGET RPC::RPC ) + add_library( RPC::RPC UNKNOWN IMPORTED ) + set_target_properties( + RPC::RPC + PROPERTIES + IMPORTED_LOCATION "${RPC_LIBRARY}" + INTERFACE_COMPILE_OPTIONS "${PC_RPC_CFLAGS_OTHER}" + INTERFACE_INCLUDE_DIRECTORIES "${RPC_INCLUDE_DIR}" + ) + + # Allow traditional/legacy style usage + set( RPC_LIBRARIES ${RPC_LIBRARY} ) + set( RPC_INCLUDE_DIRS ${RPC_INCLUDE_DIR} ) + set( RPC_DEFINITIONS ${PC_RPC_CFLAGS_OTHER} ) + + mark_as_advanced( + RPC_INCLUDE_DIR + RPC_LIBRARY + ) +endif() \ No newline at end of file diff --git a/cmake/modules/FindnetCDF-Fortran.cmake b/cmake/modules/FindnetCDF-Fortran.cmake new file mode 100644 index 0000000000..0ead239a57 --- /dev/null +++ b/cmake/modules/FindnetCDF-Fortran.cmake @@ -0,0 +1,89 @@ +# Find netcdf +# Eventually replace with netCDF-Fortran's actual config if using that +# Once found this file will define: +# netCDF-Fortran_FOUND - System has netcdf +# netCDF-Fortran_INCLUDE_DIRS - The netcdf include directories +# netCDF-Fortran_LIBRARIES - The libraries needed to use netcdf +# netCDF-Fortran_DEFINITIONS - Compiler switches required for using netcdf + +# list( REMOVE_ITEM CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR} ) +# find_package( netCDF-Fortran ) +# list( APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR} ) + + +# exit early if we don't even need to be here +if ( netCDF-Fortran_FOUND ) + return() +endif() + +############################################################################### +# First try to find using netCDF-Fortran native cmake build +# TODO : Enable this when netCDF-Fortran native cmake build works well as an imported package +# find_package( netCDF-Fortran CONFIG ) +# if ( netCDF-Fortran_FOUND ) +# message( STATUS "Found netCDF-Fortran through native cmake build" ) +# return() +# endif() +############################################################################### + +# else +# Use nf-config +find_program( + NETCDF-FORTRAN_PROGRAM + nf-config + QUIET + ) + +if ( ${NETCDF-FORTRAN_PROGRAM} MATCHES "-NOTFOUND$" ) + message( STATUS "No nf-config found" ) +else() + message( STATUS "Found NETCDF-FORTRAN_PROGRAM : ${NETCDF-FORTRAN_PROGRAM}" ) + + execute_process( COMMAND ${NETCDF-FORTRAN_PROGRAM} --includedir OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF-Fortran_INCLUDE_DIR ) + execute_process( COMMAND ${NETCDF-FORTRAN_PROGRAM} --prefix OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF-Fortran_PREFIX ) + execute_process( COMMAND ${NETCDF-FORTRAN_PROGRAM} --flibs OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF-Fortran_FLIBS ) + execute_process( COMMAND ${NETCDF-FORTRAN_PROGRAM} --version OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF-Fortran_VERSION_RAW ) + execute_process( COMMAND ${NETCDF-FORTRAN_PROGRAM} --has-nc4 OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF-Fortran_NC4_YES ) + + # check for large file support + find_file( netCDF-Fortran_INCLUDE_FILE netcdf.inc ${netCDF-Fortran_INCLUDE_DIR} ) + file( READ ${netCDF-Fortran_INCLUDE_FILE} netCDF-Fortran_INCLUDE_FILE_STR ) + string( FIND "${netCDF-Fortran_INCLUDE_FILE_STR}" "nf_format_64bit_data" netCDF-Fortran_LARGE_FILE_SUPPORT_FOUND ) + if ( ${netCDF-Fortran_LARGE_FILE_SUPPORT_FOUND} EQUAL -1 ) + set( netCDF-Fortran_LARGE_FILE_SUPPORT "NO" ) + else() + set( netCDF-Fortran_LARGE_FILE_SUPPORT "YES" ) + endif() + + # Sanitize version + string( REPLACE " " ";" netCDF-Fortran_VERSION_LIST ${netCDF-Fortran_VERSION_RAW} ) + list( GET netCDF-Fortran_VERSION_LIST -1 netCDF-Fortran_VERSION ) + + # Convert to YES/NO - Note cannot be generator expression if you want to use it during configuration time + string( TOUPPER ${netCDF-Fortran_NC4_YES} netCDF-Fortran_NC4 ) + + set( netCDF-Fortran_DEFINITIONS ) + set( netCDF-Fortran_LIBRARY_DIR ${netCDF-Fortran_PREFIX}/lib ) + + set( netCDF-Fortran_LIBRARIES + $<$:${netCDF-Fortran_FLIBS}> + ) + + # Because we may need this for in-situ manual preprocessing do not use genex + set( netCDF-Fortran_INCLUDE_DIRS ${netCDF-Fortran_INCLUDE_DIR} ) +endif() + +find_package( PkgConfig ) + +include(FindPackageHandleStandardArgs) + +# handle the QUIETLY and REQUIRED arguments and set netCDF-Fortran_FOUND to TRUE +# if all listed variables are TRUE +find_package_handle_standard_args( + netCDF-Fortran DEFAULT_MSG + netCDF-Fortran_INCLUDE_DIRS + netCDF-Fortran_FLIBS + netCDF-Fortran_VERSION + ) + +mark_as_advanced( netCDF-Fortran_FLIBS netCDF-Fortran_PREFIX netCDF-Fortran_LIBRARY_DIR ) \ No newline at end of file diff --git a/cmake/modules/FindnetCDF.cmake b/cmake/modules/FindnetCDF.cmake new file mode 100644 index 0000000000..518ec95348 --- /dev/null +++ b/cmake/modules/FindnetCDF.cmake @@ -0,0 +1,95 @@ +# Find netcdf +# Eventually replace with netCDF's actual config if using that +# Once found this file will define: +# netCDF_FOUND - System has netcdf +# netCDF_INCLUDE_DIRS - The netcdf include directories +# netCDF_LIBRARIES - The libraries needed to use netcdf +# netCDF_DEFINITIONS - Compiler switches required for using netcdf + +# list( REMOVE_ITEM CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR} ) +# find_package( netCDF ) +# list( APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR} ) + +# exit early if we don't even need to be here +if ( netCDF_FOUND ) + return() +endif() + + +############################################################################### +# First try to find using netCDF native cmake build +# TODO : Enable this when netCDF native cmake build works well as an imported package +# find_package( netCDF CONFIG ) +# if ( netCDF_FOUND ) +# message( STATUS "Found netCDF through native cmake build" ) +# return() +# endif() +############################################################################### + + +# else +# Use nc-config +find_program( + NETCDF_PROGRAM + nc-config + QUIET + ) + +if ( ${NETCDF_PROGRAM} MATCHES "-NOTFOUND$" ) + message( STATUS "No nc-config found" ) +else() + message( STATUS "Found NETCDF_PROGRAM : ${NETCDF_PROGRAM}" ) + + execute_process( COMMAND ${NETCDF_PROGRAM} --includedir OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_INCLUDE_DIR ) + execute_process( COMMAND ${NETCDF_PROGRAM} --libdir OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_LIBRARY_DIR ) + execute_process( COMMAND ${NETCDF_PROGRAM} --prefix OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_PREFIX ) + execute_process( COMMAND ${NETCDF_PROGRAM} --libs OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_CLIBS ) + execute_process( COMMAND ${NETCDF_PROGRAM} --version OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_VERSION_RAW ) + execute_process( COMMAND ${NETCDF_PROGRAM} --has-nc4 OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_NC4_YES ) + execute_process( COMMAND ${NETCDF_PROGRAM} --has-pnetcdf OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_PNETCDF_YES ) + execute_process( COMMAND ${NETCDF_PROGRAM} --has-parallel OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE netCDF_PARALLEL_YES ) + + # check for large file support + find_file( netCDF_INCLUDE_FILE netcdf.h ${netCDF_INCLUDE_DIR} ) + file( READ ${netCDF_INCLUDE_FILE} netCDF_INCLUDE_FILE_STR ) + string( FIND "${netCDF_INCLUDE_FILE_STR}" "NC_FORMAT_64BIT_DATA" netCDF_LARGE_FILE_SUPPORT_FOUND ) + if ( ${netCDF_LARGE_FILE_SUPPORT_FOUND} EQUAL -1 ) + set( netCDF_LARGE_FILE_SUPPORT "NO" ) + else() + set( netCDF_LARGE_FILE_SUPPORT "YES" ) + endif() + + # Sanitize version + string( REPLACE " " ";" netCDF_VERSION_LIST ${netCDF_VERSION_RAW} ) + list( GET netCDF_VERSION_LIST -1 netCDF_VERSION ) + + # Convert to YES/NO - Note cannot be generator expression if you want to use it during configuration time + string( TOUPPER ${netCDF_NC4_YES} netCDF_NC4 ) + string( TOUPPER ${netCDF_PNETCDF_YES} netCDF_PNETCDF ) + string( TOUPPER ${netCDF_PARALLEL_YES} netCDF_PARALLEL ) + + set( netCDF_DEFINITIONS ) + + set( netCDF_LIBRARIES + # All supported language variants will need this regardless - this may conflict with the RPATH in any + # supplemental packages so be careful to use compatible langauge versions of netCDF + $<$,$>:${netCDF_CLIBS}> + ) + # Because we may need this for in-situ manual preprocessing do not use genex + set( netCDF_INCLUDE_DIRS ${netCDF_INCLUDE_DIR} ) +endif() + +find_package( PkgConfig ) + +include(FindPackageHandleStandardArgs) + +# handle the QUIETLY and REQUIRED arguments and set netCDF_FOUND to TRUE +# if all listed variables are TRUE +find_package_handle_standard_args( netCDF DEFAULT_MSG + netCDF_INCLUDE_DIRS + netCDF_LIBRARY_DIR + netCDF_CLIBS + netCDF_VERSION + ) + +mark_as_advanced( netCDF_CLIBS netCDF_PREFIX netCDF_LIBRARY_DIR ) \ No newline at end of file diff --git a/cmake/modules/FindpnetCDF.cmake b/cmake/modules/FindpnetCDF.cmake new file mode 100644 index 0000000000..3606b94ba2 --- /dev/null +++ b/cmake/modules/FindpnetCDF.cmake @@ -0,0 +1,90 @@ +# Find pnetcdf +# Eventually replace with pnetCDF's actual config if using that +# Once found this file will define: +# pnetCDF_FOUND - System has pnetcdf +# pnetCDF_INCLUDE_DIRS - The pnetcdf include directories +# pnetCDF_LIBRARIES - The libraries needed to use pnetcdf +# pnetCDF_DEFINITIONS - Compiler switches required for using pnetcdf + +# list( REMOVE_ITEM CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR} ) +# find_package( pnetCDF ) +# list( APPEND CMAKE_MODULE_PATH ${CMAKE_CURRENT_LIST_DIR} ) + +# Use pnetcdf-config +find_program( + PNETCDF_PROGRAM + pnetcdf-config + QUIET + ) + +if ( ${PNETCDF_PROGRAM} MATCHES "-NOTFOUND$" ) + message( STATUS "No pnetcdf-config found : ${PNETCDF_PROGRAM}" ) +else() + message( STATUS "Found PNETCDF_PROGRAM : ${PNETCDF_PROGRAM}" ) + + execute_process( COMMAND ${PNETCDF_PROGRAM} --includedir OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_INCLUDE_DIR ) + execute_process( COMMAND ${PNETCDF_PROGRAM} --libdir OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_LIBRARY_DIR ) + execute_process( COMMAND ${PNETCDF_PROGRAM} --prefix OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_PREFIX ) + execute_process( COMMAND ${PNETCDF_PROGRAM} --version OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_VERSION_RAW ) + execute_process( COMMAND ${PNETCDF_PROGRAM} --netcdf4 OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_NC4_ENABLED ) + + execute_process( COMMAND ${PNETCDF_PROGRAM} --has-c++ OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_CXX_YES ) + execute_process( COMMAND ${PNETCDF_PROGRAM} --has-fortran OUTPUT_STRIP_TRAILING_WHITESPACE OUTPUT_VARIABLE pnetCDF_FORTRAN_YES ) + + # check for large file support + find_file( pnetCDF_INCLUDE_FILE pnetcdf.inc ${pnetCDF_INCLUDE_DIR} ) + file( READ ${pnetCDF_INCLUDE_FILE} pnetCDF_INCLUDE_FILE_STR ) + string( FIND "${pnetCDF_INCLUDE_FILE_STR}" "nf_format_64bit" pnetCDF_LARGE_FILE_SUPPORT_FOUND ) + if ( ${pnetCDF_LARGE_FILE_SUPPORT_FOUND} EQUAL -1 ) + set( pnetCDF_LARGE_FILE_SUPPORT "NO" ) + else() + set( pnetCDF_LARGE_FILE_SUPPORT "YES" ) + endif() + + # Sanitize version + string( REPLACE " " ";" pnetCDF_VERSION_LIST ${pnetCDF_VERSION_RAW} ) + list( GET pnetCDF_VERSION_LIST -1 pnetCDF_VERSION ) + + # Note that pnetCDF has decided to change things up and use "disabled" instead of "yes/no" + string( TOLOWER ${pnetCDF_NC4_ENABLED} pnetCDF_NC4_ENABLED ) + if ( ${pnetCDF_NC4_ENABLED} STREQUAL "enabled" ) + set( pnetCDF_NC4 "YES" ) + else() + set( pnetCDF_NC4 "NO" ) + endif() + + string( TOUPPER ${pnetCDF_CXX_YES} pnetCDF_CXX ) + string( TOUPPER ${pnetCDF_FORTRAN_YES} pnetCDF_FORTRAN ) + + + set( pnetCDF_DEFINITIONS ) + + # Find libraries + find_library( + pnetCDF_LIBRARY + NAMES pnetcdf + # Hints before PATHS + HINTS ${pnetCDF_LIBRARY_DIR} + NO_DEFAULT_PATH + ) + + + set( pnetCDF_LIBRARIES + $<$:${pnetCDF_LIBRARY}> + $<$:$<$:${pnetCDF_LIBRARY}>> + $<$:$<$:${pnetCDF_LIBRARY}>> + ) + set( pnetCDF_INCLUDE_DIRS ${pnetCDF_INCLUDE_DIR} ) +endif() +find_package( PkgConfig ) +include(FindPackageHandleStandardArgs) + +# handle the QUIETLY and REQUIRED arguments and set pnetCDF_FOUND to TRUE +# if all listed variables are TRUE +find_package_handle_standard_args( pnetCDF DEFAULT_MSG + pnetCDF_INCLUDE_DIRS + pnetCDF_LIBRARIES + pnetCDF_VERSION + ) + +# mark_as_advanced( pnetCDF_CLIBS pnetCDF_CXXLIBS pnetCDF_FLIBS ) \ No newline at end of file diff --git a/cmake/printOption.cmake b/cmake/printOption.cmake new file mode 100644 index 0000000000..f00d893e9a --- /dev/null +++ b/cmake/printOption.cmake @@ -0,0 +1,54 @@ +# https://stackoverflow.com/a/19578320 +# Some color defintions +if ( NOT "${PRINT_OPTION_SUPPRESS_COLOR}" ) + if ( NOT WIN32 ) + string( ASCII 27 ESC ) + set( COLOR_RESET "${ESC}[m" ) + set( COLOR_BOLD "${ESC}[1m" ) + set( RED "${ESC}[31m" ) + set( GREEN "${ESC}[32m" ) + set( YELLOW "${ESC}[33m" ) + set( BLUE "${ESC}[34m" ) + set( MAGENTA "${ESC}[35m" ) + set( CYAN "${ESC}[36m" ) + set( WHITE "${ESC}[37m" ) + set( BOLD_RED "${ESC}[1;31m" ) + set( BOLD_GREEN "${ESC}[1;32m" ) + set( BOLD_YELLOW "${ESC}[1;33m" ) + set( BOLD_BLUE "${ESC}[1;34m" ) + set( BOLD_MAGENTA "${ESC}[1;35m" ) + set( BOLD_CYAN "${ESC}[1;36m" ) + set( BOLD_WHITE "${ESC}[1;37m" ) + endif() +endif() + +function( print_option ) + set( OPTION ${ARGV0} ) + set( JUSTIFY ${ARGV1} ) + + if ( ${ARGC} GREATER_EQUAL 3 ) + set( ALT_COLOR ${ARGV2} ) + endif() + + if ( DEFINED ALT_COLOR ) + set( OPT_COLOR ${ALT_COLOR} ) + else() + set( OPT_COLOR ${RED} ) + if ( ${${OPTION}} ) + set( OPT_COLOR ${GREEN} ) + endif() + endif() + + set( OPTION_STR "${OPTION}" ) + string( LENGTH ${OPTION_STR} OPTION_STR_LEN ) + math( EXPR N_JUSTIFY "${JUSTIFY} - ${OPTION_STR_LEN}" ) + + if ( ${N_JUSTIFY} LESS 1 ) + set( N_JUSTIFY 1 ) + endif() + + string( REPEAT " " ${N_JUSTIFY} JUSTIFY_WHITESPACE ) + + message( STATUS "${OPTION_STR}${JUSTIFY_WHITESPACE} : ${OPT_COLOR}${${OPTION}}${COLOR_RESET}" ) + +endfunction() \ No newline at end of file diff --git a/cmake/target_copy.cmake b/cmake/target_copy.cmake new file mode 100644 index 0000000000..429eddc976 --- /dev/null +++ b/cmake/target_copy.cmake @@ -0,0 +1,75 @@ +# WRF Macro for copying files with generated dependency +# https://stackoverflow.com/a/34800230 +macro( wrf_copy_source_files ) + + set( options ) + set( oneValueArgs TARGET_NAME SUFFIX PREFIX EXTENSION OUTPUT_DIR ) + set( multiValueArgs DEPENDENCIES SOURCES ) + + cmake_parse_arguments( + WRF_COPY + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + + # Generate compile command and file outputs + set( WRF_COPY_OUTPUT ) + set( WRF_COPY_COMMANDS ) + foreach( WRF_COPY_SOURCE_FILE ${WRF_COPY_SOURCES} ) + get_filename_component( WRF_COPY_INPUT_SOURCE ${WRF_COPY_SOURCE_FILE} REALPATH ) + get_filename_component( WRF_COPY_INPUT_SOURCE_FILE_ONLY ${WRF_COPY_SOURCE_FILE} NAME ) + + if ( ${WRF_COPY_EXTENSION} MATCHES "^[.][a-z0-9]+$" ) + string( REGEX REPLACE "[.].*$" "${WRF_COPY_EXTENSION}" WRF_COPY_OUTPUT_FILE ${WRF_COPY_INPUT_SOURCE_FILE_ONLY} ) + else() + # Default to original filename + set( WRF_COPY_OUTPUT_FILE ${WRF_COPY_INPUT_SOURCE_FILE_ONLY} ) + endif() + + set( WRF_COPY_OUTPUT_FILE ${WRF_COPY_OUTPUT_DIR}/${WRF_COPY_PREFIX}${WRF_COPY_OUTPUT_FILE}${WRF_COPY_SUFFIX} ) + + + list( + APPEND WRF_COPY_COMMANDS + COMMAND ${CMAKE_COMMAND} -E copy ${WRF_COPY_INPUT_SOURCE} ${WRF_COPY_OUTPUT_FILE} + # Force check that they were made + COMMAND ${CMAKE_COMMAND} -E compare_files ${WRF_COPY_OUTPUT_FILE} ${WRF_COPY_OUTPUT_FILE} + ) + list( + APPEND WRF_COPY_OUTPUT + ${WRF_COPY_OUTPUT_FILE} + ) + + # # Tell all targets that eventually use this file that it is generated - this is useful if this macro is used in a + # # different directory than where the target dependency is set + # # Thanks to https://gitlab.kitware.com/cmake/community/-/wikis/FAQ#how-can-i-add-a-dependency-to-a-source-file-which-is-generated-in-a-subdirectory + # # and https://samthursfield.wordpress.com/2015/11/21/cmake-dependencies-between-targets-and-files-and-custom-commands/ + # # It keeps getting better lol + # # https://gitlab.kitware.com/cmake/cmake/-/issues/18399 + # # We could use cmake 3.20+ and CMP0118, but this allows usage from 3.18.6+ + # TL;DR - This doesn't work despite all documentation stating otherwise, need to use CMP0118 + # set_source_files_properties( + # ${WRF_COPY_OUTPUT_FILE} + # ${WRF_COPY_TARGET_DIRECTORY} + # PROPERTIES + # GENERATED TRUE + # ) + + message( STATUS "File ${WRF_COPY_SOURCE_FILE} will be copied to ${WRF_COPY_OUTPUT_FILE}" ) + + endforeach() + + # Preprocess sources into a custom target + add_custom_command( + OUTPUT ${WRF_COPY_OUTPUT} + COMMAND ${CMAKE_COMMAND} -E make_directory ${WRF_COPY_OUTPUT_DIR} + ${WRF_COPY_COMMANDS} + COMMENT "Preprocessing ${WRF_COPY_TARGET_NAME}" + DEPENDS ${WRF_COPY_DEPENDENCIES} + ) + + add_custom_target( + ${WRF_COPY_TARGET_NAME} + DEPENDS ${WRF_COPY_OUTPUT} + ) +endmacro() diff --git a/cmake/template/WRFConfig.cmake.in b/cmake/template/WRFConfig.cmake.in new file mode 100644 index 0000000000..f896e0f420 --- /dev/null +++ b/cmake/template/WRFConfig.cmake.in @@ -0,0 +1,54 @@ +# WRF CMake Package + +@PACKAGE_INIT@ + +include( "${CMAKE_CURRENT_LIST_DIR}/@EXPORT_NAME@Targets.cmake" ) + +set( WRF_VERSION @PROJECT_VERSION@ ) + +# Options WRF was built with +set( WRF_CORE @WRF_CORE@ ) +set( WRF_NESTING @WRF_NESTING@ ) +set( WRF_CASE @WRF_CASE@ ) + +set( WRF_USE_DOUBLE @USE_DOUBLE@ ) +set( WRF_USE_MPI @USE_MPI@ ) +set( WRF_USE_OPENMP @USE_OPENMP@ ) +set( WRF_ENABLE_CHEM @ENABLE_CHEM@ ) +set( WRF_ENABLE_CMAQ @ENABLE_CMAQ@ ) +set( WRF_ENABLE_KPP @ENABLE_KPP@ ) +set( WRF_ENABLE_DFI_RADAR @ENABLE_DFI_RADAR@ ) +set( WRF_ENABLE_TITAN @ENABLE_TITAN@ ) +set( WRF_ENABLE_MARS @ENABLE_MARS@ ) +set( WRF_ENABLE_VENUS @ENABLE_VENUS@ ) +set( WRF_ENABLE_VENUS @ENABLE_VENUS@ ) +set( WRF_ENABLE_TERRAIN @ENABLE_TERRAIN@ ) +set( WRF_ENABLE_CLM @ENABLE_CLM@ ) +set( WRF_USE_ALLOCATABLES @USE_ALLOCATABLES@ ) +set( WRF_wrfmodel @wrfmodel@ ) +set( WRF_GRIB1 @GRIB1@ ) +set( WRF_INTIO @INTIO@ ) +set( WRF_KEEP_INT_AROUND @KEEP_INT_AROUND@ ) +set( WRF_LIMIT_ARGS @LIMIT_ARGS@ ) +set( WRF_FORCE_NETCDF_CLASSIC @FORCE_NETCDF_CLASSIC@ ) +set( WRF_BUILD_RRTMG_FAST @BUILD_RRTMG_FAST@ ) +set( WRF_BUILD_RRTMK @BUILD_RRTMK@ ) +set( WRF_BUILD_SBM_FAST @BUILD_SBM_FAST@ ) +set( WRF_SHOW_ALL_VARS_USED @SHOW_ALL_VARS_USED@ ) +set( WRF_WRFIO_NCD_NO_LARGE_FILE_SUPPORT @WRFIO_NCD_NO_LARGE_FILE_SUPPORT@ ) + + +if ( ${WRF_USE_MPI} ) + find_package( MPI REQUIRED COMPONENTS Fortran C ) +endif() + +if ( ${WRF_USE_OPENMP} ) + find_package( OpenMP REQUIRED COMPONENTS Fortran C ) +endif() + +find_package( netCDF REQUIRED ) +# Attempt to find zlib packaged with netcdf first +set( ZLIB_ROOT ${netCDF_PREFIX} ) +find_package( ZLIB REQUIRED ) + +check_required_components( "@EXPORT_NAME@_Core" ) \ No newline at end of file diff --git a/cmake/template/arch_config.cmake b/cmake/template/arch_config.cmake new file mode 100644 index 0000000000..42cba60287 --- /dev/null +++ b/cmake/template/arch_config.cmake @@ -0,0 +1,29 @@ +# https://cmake.org/cmake/help/latest/module/FindMPI.html#variables-for-locating-mpi +set( MPI_Fortran_COMPILER "{DM_FC}" ) +set( MPI_C_COMPILER "{DM_CC}" ) + +# https://cmake.org/cmake/help/latest/variable/CMAKE_LANG_COMPILER.html +set( CMAKE_Fortran_COMPILER "{SFC}" ) +set( CMAKE_C_COMPILER "{SCC}" ) + +# Our own addition +set( CMAKE_C_PREPROCESSOR "{CPP}" ) +set( CMAKE_C_PREPROCESSOR_FLAGS {CPP_FLAGS} ) + +# https://cmake.org/cmake/help/latest/variable/CMAKE_LANG_FLAGS_INIT.html +set( CMAKE_Fortran_FLAGS_INIT "{SFC_FLAGS} {FCBASEOPTS} {BYTESWAPIO}" ) +set( CMAKE_C_FLAGS_INIT "{SCC_FLAGS} {CFLAGS_LOCAL}" ) + +# https://cmake.org/cmake/help/latest/variable/CMAKE_LANG_FLAGS_CONFIG_INIT.html +set( CMAKE_Fortran_FLAGS_DEBUG_INIT "{FCDEBUG}" ) +set( CMAKE_Fortran_FLAGS_RELEASE_INIT "" ) +set( CMAKE_C_FLAGS_DEBUG_INIT "" ) +set( CMAKE_C_FLAGS_RELEASE_INIT "" ) + +# Project specifics now +set( WRF_MPI_Fortran_FLAGS "{DM_FC_FLAGS}" ) +set( WRF_MPI_C_FLAGS "{DM_CC_FLAGS}" ) +set( WRF_ARCH_LOCAL "{ARCH_LOCAL}" ) +set( WRF_M4_FLAGS "{M4_FLAGS}" ) +set( WRF_FCOPTIM "{FCOPTIM}" ) +set( WRF_FCNOOPT "{FCNOOPT}" ) \ No newline at end of file diff --git a/cmake/template/commit_decl.cmake b/cmake/template/commit_decl.cmake new file mode 100644 index 0000000000..bcc368835b --- /dev/null +++ b/cmake/template/commit_decl.cmake @@ -0,0 +1 @@ + CHARACTER (LEN=*), PARAMETER :: commit_version = '@GIT_VERSION@' \ No newline at end of file diff --git a/cmake/wrf_case_setup.cmake b/cmake/wrf_case_setup.cmake new file mode 100644 index 0000000000..4e65dc0a72 --- /dev/null +++ b/cmake/wrf_case_setup.cmake @@ -0,0 +1,124 @@ +# WRF Macro for adding target symlinks/copies to be run after internal install() code +macro( wrf_setup_targets ) + + set( options USE_SYMLINKS ) + set( oneValueArgs DEST_PATH ) + set( multiValueArgs TARGETS ) + + cmake_parse_arguments( + WRF_SETUP + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + set( WRF_SETUP_CMD copy_if_different ) + if ( ${WRF_SETUP_USE_SYMLINKS} ) + set( WRF_SETUP_CMD create_symlink ) + endif() + + + foreach ( WRF_SETUP_TARGET ${WRF_SETUP_TARGETS} ) + + # Generate install code for each target + # https://stackoverflow.com/a/56528615 + #!TODO Do we *need* the rm for symlinks beforehand? + # get_filename_component( WRF_SETUP_FILE_ONLY $ NAME + + # If we ever wanted to link or copy things other than binaries we could change this + set( WRF_SETUP_INSTALL_LOCATION ${CMAKE_INSTALL_PREFIX}/bin ) + + install( + CODE " + message( STATUS \"Setting up $ via ${WRF_SETUP_CMD}\" ) + execute_process( COMMAND ${CMAKE_COMMAND} -E ${WRF_SETUP_CMD} ${WRF_SETUP_INSTALL_LOCATION}/$ ${WRF_SETUP_DEST_PATH}/$ ) + " + COMPONENT setup + ) + + # Add .exe link as well + install( + CODE " + message( STATUS \"Creating symlink for $.exe\" ) + execute_process( COMMAND ${CMAKE_COMMAND} -E create_symlink ${WRF_SETUP_DEST_PATH}/$ ${WRF_SETUP_DEST_PATH}/$.exe ) + " + COMPONENT setup + ) + + endforeach() + +endmacro() + +# WRF Macro for adding file symlinks/copies to be run after internal install() code +macro( wrf_setup_files ) + + set( options USE_SYMLINKS ) + set( oneValueArgs DEST_PATH ) + set( multiValueArgs FILES ) + + cmake_parse_arguments( + WRF_SETUP + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + set( WRF_SETUP_CMD copy_if_different ) + if ( ${WRF_SETUP_USE_SYMLINKS} ) + set( WRF_SETUP_CMD create_symlink ) + endif() + + foreach ( WRF_SETUP_FILE ${WRF_SETUP_FILES} ) + + # Generate install code for each file, this could be done in a simpler manner + # with regular commands but to preserve order of operations it will be done via install( CODE ... ) + # https://stackoverflow.com/a/56528615 + get_filename_component( WRF_SETUP_FULL_FILE ${WRF_SETUP_FILE} ABSOLUTE ) + get_filename_component( WRF_SETUP_FILE_ONLY ${WRF_SETUP_FILE} NAME ) + # Left here for debug purposes, may want to turn this into a trace-level debug msg + # message( "Generating install commands for ${WRF_SETUP_FILE_ONLY} into ${WRF_SETUP_DEST_PATH}" ) + install( + CODE " + message( STATUS \"Setting up ${WRF_SETUP_FILE_ONLY} via ${WRF_SETUP_CMD}\" ) + execute_process( COMMAND ${CMAKE_COMMAND} -E ${WRF_SETUP_CMD} ${WRF_SETUP_FULL_FILE} ${WRF_SETUP_DEST_PATH}/${WRF_SETUP_FILE_ONLY} ) + " + COMPONENT setup + ) + + endforeach() + +endmacro() + +# WRF Macro for adding file symlink to be run after internal install() code +macro( wrf_setup_file_new_name ) + + set( options USE_SYMLINKS ) + set( oneValueArgs FILE NEW_NAME ) + set( multiValueArgs ) + + cmake_parse_arguments( + WRF_SETUP + "${options}" "${oneValueArgs}" "${multiValueArgs}" + ${ARGN} + ) + + set( WRF_SETUP_CMD copy_if_different ) + if ( ${WRF_SETUP_USE_SYMLINKS} ) + set( WRF_SETUP_CMD create_symlink ) + endif() + + # Generate install code for each file, this could be done in a simpler manner + # with regular commands but to preserve order of operations it will be done via install( CODE ... ) + # https://stackoverflow.com/a/56528615 + get_filename_component( WRF_SETUP_FULL_FILE ${WRF_SETUP_FILE} ABSOLUTE ) + get_filename_component( WRF_SETUP_FILE_ONLY ${WRF_SETUP_FILE} NAME ) + get_filename_component( WRF_SETUP_NEW_NAME_FULL_FILE ${WRF_SETUP_NEW_NAME} ABSOLUTE ) + get_filename_component( WRF_SETUP_NEW_NAME_FILE_ONLY ${WRF_SETUP_NEW_NAME} NAME ) + # Left here for debug purposes, may want to turn this into a trace-level debug msg + # message( "Generating install commands for ${WRF_SETUP_FILE_ONLY} to ${WRF_SETUP_NEW_NAME_FILE_ONLY}" ) + install( + CODE " + message( STATUS \"Setting up ${WRF_SETUP_FILE_ONLY} (rename ${WRF_SETUP_NEW_NAME_FILE_ONLY}) via ${WRF_SETUP_CMD}\" ) + execute_process( COMMAND ${CMAKE_COMMAND} -E ${WRF_SETUP_CMD} ${WRF_SETUP_FULL_FILE} ${WRF_SETUP_NEW_NAME_FULL_FILE} ) + " + COMPONENT setup + ) + +endmacro() + diff --git a/cmake/wrf_get_version.cmake b/cmake/wrf_get_version.cmake new file mode 100644 index 0000000000..668c9d6941 --- /dev/null +++ b/cmake/wrf_get_version.cmake @@ -0,0 +1,11 @@ +# WRF Macro for getting version, this *should* be replaced with a better versioning scheme +macro( wrf_get_version WRF_VERSION_FILE ) + file( STRINGS ${WRF_VERSION_FILE} WRF_VERSION_FILE_OUTPUT ) + + list( POP_FRONT WRF_VERSION_FILE_OUTPUT FIRST_LINE ) + string( REPLACE " " ";" FIRST_LINE_LIST ${FIRST_LINE} ) + list( GET FIRST_LINE_LIST -1 WRF_VERSION ) + + set( PROJECT_VERSION ${WRF_VERSION} ) + message( STATUS "Setting project version to ${PROJECT_VERSION}" ) +endmacro() diff --git a/compile b/compile index 0595d05db1..e3e2c49b1f 100755 --- a/compile +++ b/compile @@ -351,7 +351,7 @@ else setenv BUFR 1 endif if ( -e ${RTTOV}/lib/librttov12_main.a ) then - setenv RTTOV_LIB "-L${hdf5path}/lib -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -L${RTTOV}/lib -lrttov12_coef_io -lrttov12_emis_atlas -lrttov12_main -lrttov12_hdf" + setenv RTTOV_LIB "-L${hdf5path}/lib -lhdf5_hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -lhdf5_hl_f90cstub -lhdf5_f90cstub -lhdf5_hl_cpp -L${RTTOV}/lib -lrttov12_coef_io -lrttov12_emis_atlas -lrttov12_main -lrttov12_hdf" else echo "Can not find a compatible RTTOV library! Please ensure that your RTTOV build was successful," echo "your 'RTTOV' environment variable is set correctly, and you are using a supported version of RTTOV." @@ -407,15 +407,17 @@ else echo " " uname -a echo " " - set comp = ( `grep "^SFC" configure.wrf | cut -d"=" -f2-` ) - if ( "$comp[1]" == "gfortran" ) then - gfortran --version - else if ( "$comp[1]" == "pgf90" ) then - pgf90 --version - else if ( "$comp[1]" == "ifort" ) then - ifort -V + set comp = ( `grep "^SFC" configure.wrf | cut -d"#" -f1 | cut -d"=" -f2-` ) + $comp[1] -V >& /dev/null + if ( $status == 0 ) then + $comp[1] -V else - echo "Not sure how to figure out the version of this compiler: $comp[1]" + $comp[1] --version >& /dev/null + if ( $status == 0 ) then + $comp[1] --version + else + echo "Not sure how to figure out the version of this compiler: $comp[1]" + endif endif echo " " echo "============================================================================================== " diff --git a/compile_new b/compile_new new file mode 100755 index 0000000000..721df9d3bf --- /dev/null +++ b/compile_new @@ -0,0 +1,13 @@ +#!/bin/sh +# Meant to be run at the top level + +# Now run cmake +buildDirectory=$1 +if [ ! -d "$buildDirectory" ]; then + buildDirectory=$PWD/_build + echo "Using default build directory : ${buildDirectory}" +else + shift +fi +cd $buildDirectory && make install $* +exit $? \ No newline at end of file diff --git a/confcheck/CMakeLists.txt b/confcheck/CMakeLists.txt new file mode 100644 index 0000000000..152aeeaa3a --- /dev/null +++ b/confcheck/CMakeLists.txt @@ -0,0 +1,87 @@ +# WRF configuration checks +wrf_conf_check( + RUN + RESULT_VAR Fortran_2003_IEEE + SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_ieee_test.F + EXTENSION .F + MESSAGE "Some IEEE Fortran 2003 features missing, removing usage of these features" + ) + +wrf_conf_check( + RUN + RESULT_VAR Fortran_2003_ISO_C + SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_iso_c_test.F + EXTENSION .F + MESSAGE "Some ISO_C Fortran 2003 features missing, removing usage ISO_C and stubbing code dependent on it" + ) + +wrf_conf_check( + RUN + RESULT_VAR Fortran_2003_FLUSH + SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_flush_test.F + EXTENSION .F + MESSAGE "Standard FLUSH routine Fortran 2003 features missing, checking for alternate Fortran_2003_FFLUSH" + ) + +if ( NOT ${Fortran_2003_FLUSH} ) + wrf_conf_check( + RUN + RESULT_VAR Fortran_2003_FFLUSH + SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2003_fflush_test.F + EXTENSION .F + MESSAGE "Standard FFLUSH routine Fortran 2003 features missing, no alternate to FLUSH found, feature stubbed out" + ) +endif() + +wrf_conf_check( + RUN + RESULT_VAR Fortran_2003_GAMMA + SOURCE ${PROJECT_SOURCE_DIR}/tools/fortran_2008_gamma_test.F + EXTENSION .F + MESSAGE "Some Fortran 2003 features missing, removing usage gamma function intrinsic and stubbing code dependent on it" + ) + + + +wrf_conf_check( + RUN + SOURCE_TYPE C + RESULT_VAR FSEEKO64 + SOURCE ${PROJECT_SOURCE_DIR}/tools/fseek_test.c + EXTENSION .c + ADDITIONAL_DEFINITIONS -DTEST_FSEEKO64 -DFILE_TO_TEST="${PROJECT_SOURCE_DIR}/CMakeLists.txt" + MESSAGE "fseeko64 not supported, checking alternate fseeko" + ) + +if ( NOT "${FSEEKO64}" ) + wrf_conf_check( + RUN + SOURCE_TYPE C + RESULT_VAR FSEEKO + SOURCE ${PROJECT_SOURCE_DIR}/tools/fseek_test.c + EXTENSION .c + ADDITIONAL_DEFINITIONS -DTEST_FSEEKO -DFILE_TO_TEST="${PROJECT_SOURCE_DIR}/CMakeLists.txt" + MESSAGE "fseeko not supported, compiling with fseek (caution with large files)" + ) +endif() + +# Unsure if this is even necessary. Defines littered throughout configure.defaults +# if ( ${USE_MPI} ) +# wrf_conf_check( +# RUN +# SOURCE_TYPE C +# RESULT_VAR MPI2_SUPPORT +# SOURCE ${PROJECT_SOURCE_DIR}/tools/mpi2_test.c +# EXTENSION .c +# MESSAGE "MPI_Comm_f2c() and MPI_Comm_c2f() not supported" +# ) + +# wrf_conf_check( +# RUN +# SOURCE_TYPE C +# RESULT_VAR MPI2_THREAD_SUPPORT +# SOURCE ${PROJECT_SOURCE_DIR}/tools/mpi2_thread_test.c +# EXTENSION .c +# MESSAGE "MPI_Init_thread() not supported" +# ) +# endif() \ No newline at end of file diff --git a/configure b/configure index 27b01b19ce..5e2bedb10f 100755 --- a/configure +++ b/configure @@ -50,7 +50,7 @@ if [ -n "$print_usage" ] ; then echo '-help print this message' echo '*****************************************************************************' echo ' ' - exit + exit fi if `pwd | grep ' ' > /dev/null ` ; then @@ -59,7 +59,7 @@ if `pwd | grep ' ' > /dev/null ` ; then echo and this may cause problems for your build. This can occur, for example, on echo Windows systems. It is strongly recommended that you install WRF and other echo related software such as NetCDF in directories whose path names contain no - echo white space. On Win, for example, create and install in a directory under C:. + echo white space. On Windows, for example, create and install in a directory under C:. echo '*****************************************************************************' fi @@ -123,7 +123,7 @@ do else echo "$ac_t""found $ac_prog_where ($PERL)" 1>&1 fi - PERLFULLPATH=$ac_prog_where + PERLFULLPATH=$ac_prog_where else if test -z "$ac_echo_test" -a 1 = 1 ; then echo "$ac_t""no" @@ -135,16 +135,16 @@ do done if test -z "$PERL" ; then - # We have to set this outside of the loop lest the first failure in + # We have to set this outside of the loop lest the first failure in # PROGRAM_CHECK set the value (which then terminates the effect of the - # loop, since autoconf macros only set values that are null, they + # loop, since autoconf macros only set values that are null, they # don't override them PERL="" fi if test -n "$PERL" ; then PERL="$PERL" - + perlversion=`$PERL -v | grep 'This is perl' | \ sed -e 's/^.*v[a-z ]*\([0-9]\).*$/\1/'` @@ -159,8 +159,31 @@ if test -n "$PERL" ; then fi -if [ -e $NETCDF/bin/nc-config ] ; then - ncversion=`nc-config --version | awk '{print $2}'` +# We just need to find nc-config. First, check if NETCDF_C is set; if not, check +# $NETCDF/bin; otherwise, try `which nc-config`. If all that fails, warn user that WRF +# may fail to build beacuse of an incomplete NetCDF configuration. It could still be +# successfull if NetCDF was built statically because the results of `nf-config --flibs` +# should contain the necessary information for linking as long as NetCDF-Fortran is not +# version 4.5.3 (see https://github.com/Unidata/netcdf-fortran/issues/270) + +if [ -n "$NETCDF_C" ] ; then + if [ -f "$NETCDF_C/bin/nc-config" ] ; then + export NETCDF_C=$NETCDF_C + fi +elif [ -f "${NETCDF}/bin/nc-config" ] ; then + export NETCDF_C=$NETCDF +else + ans="`which nc-config`" + status="$?" + if [ "$ans" != "nc-config:" -a "$ans" != "" -a "$status" = "0" ] ; then + export NETCDF_C=`echo $ans | awk -F/ '{NF=NF-2;$NF=$NF}1' OFS=/` + else + export NETCDF_C="NOT_FOUND" + fi +fi + +if [ -e $NETCDF_C/bin/nc-config ] ; then + ncversion=`$NETCDF_C/bin/nc-config --version | awk '{print $2}'` else ncversion=OLD fi @@ -168,10 +191,10 @@ fi PROBS=FALSE if [ -n "$NETCDFPAR" ] ; then NETCDF="$NETCDFPAR" - if [ ! -e $NETCDF/bin/nc-config ] ; then + if [ ! -e $NETCDF_C/bin/nc-config ] ; then PROBS=TRUE else - ncversion=`nc-config --version | awk '{print $2}'` + ncversion=`$NETCDF_C/bin/nc-config --version | awk '{print $2}'` ncversiona=`echo $ncversion | cut -c 1` ncversionb=`echo $ncversion | cut -c 3` ncversionc=`echo $ncversion | cut -c 5` @@ -196,6 +219,8 @@ if [ -n "$NETCDFPAR" ] ; then export NETCDF export NETCDF4 export USENETCDFPAR +else + export USENETCDFPAR=0 fi if test -z "$NETCDF" ; then @@ -224,7 +249,7 @@ if [ -n "$NETCDF" ] ; then else USENETCDFF=" " fi - if [ -f "$NETCDF/lib/libnetcdf.a" -o -f "$NETCDF/lib/libnetcdf.so" -o -f "$NETCDF/lib/libnetcdf.dll.a" ] ; then + if [ -f "$NETCDF_C/lib/libnetcdf.a" -o -f "$NETCDF_C/lib/libnetcdf.so" -o -f "$NETCDF_C/lib/libnetcdf.dll.a" ] ; then USENETCDF="-lnetcdf" else USENETCDF=" " @@ -243,9 +268,7 @@ fi # If the user asked for classic netcdf, acquiesce to the request. -ans="`which nf-config`" -status="$?" -if [ "$ans" = "nf-config:" -o "$ans" = "" -o "$status" != "0" ] ; then +if [ ! -f "$NETCDF/bin/nf-config" ] ; then export NETCDF_classic=1 unset NETCDF4 else @@ -257,7 +280,7 @@ else export NETCDF4=1 fi else - if [ "`nf-config --has-nc4`" = "yes" ] ; then + if [ "`$NETCDF/bin/nf-config --has-nc4`" = "yes" ] ; then unset NETCDF_classic export NETCDF4=1 else @@ -274,76 +297,19 @@ if [ -z "$CURL_PATH" ] ; then CURL_PATH=''; fi if [ -n "$NETCDF4" ] ; then if [ $NETCDF4 -eq 1 ] ; then - DEP_LIB_PATH='' - if [ -f $NETCDF/bin/nf-config ] ; then - nx_config="$NETCDF/bin/nf-config --flibs" - DEP_LIB_PATH="`$nx_config | awk '{for(i=1;i<=NF;i++){if(match($i, /-L.*/)) {print $i} } }'`" - CURL="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lcurl") {print $i} } }'`" - GPFS="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lgpfs") {print $i} } }'`" - fi - if [ "$DEP_LIB_PATH" = '' ] ; then - if [ -f $NETCDF/bin/nc-config ] ; then - nx_config="$NETCDF/bin/nc-config --libs" - DEP_LIB_PATH="`$nx_config | awk '{for(i=1;i<=NF;i++){if(match($i, /-L.*/)) {print $i} } }'`" - CURL="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lcurl") {print $i} } }'`" - GPFS="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lgpfs") {print $i} } }'`" - if [ "$CURL" != '' -a "$CURL_PATH" = '' ] ; then - CURL_PATH="DEFAULT" - fi - if [ "$GPFS" != '' -a "$GPFS_PATH" = '' ] ; then - GPFS_PATH="DEFAULT" - fi - fi - fi - for P in "$HDF5_PATH" "$ZLIB_PATH" "$GPFS_PATH" "$CURL_PATH" - do - if [ "$P" != '' -a "$P" != "DEFAULT" ] ; then - if [ "${P#${P%?}}" = "/" ] ; then - P=`echo $P | sed 's/\/$//'` - fi - DEP_LIB_PATH="`echo $DEP_LIB_PATH | awk -v VAR=-L$P/lib '{for(i=1;i<=NF;i++){if ($i != VAR ) {print $i} } }'`" - DEP_LIB_PATH="$DEP_LIB_PATH -L$P/lib" - fi - done - if [ "${NETCDF#${NETCDF%?}}" = "/" ] ; then - NETCDF=`echo $NETCDF | sed 's/\/$//'` - fi - buff="`ls -l $NETCDF | sed 's/ */ /g'`" - while [ "`echo $buff | grep lib`" = "" -a "`echo $buff | grep '\->'`" != "" ] - do - buff="`echo $buff | sed -e 's/->//' -e 's/ */ /g'`" - n=`echo $buff | wc -w` - lastword=`echo "$buff" | cut -d' ' -f$n | sed 's/\/$//'` - c="`echo $lastword | cut -c1`" - if [ "$c" = "/" ] ; then - NETCDF=$lastword - else - c="`echo $lastword | cut -c1-2`" - if [ "$c" = "./" ] ; then - lastword="echo $lastword | cut -c3-" - fi - NETCDF=${NETCDF%/*}/$lastword - fi - buff="`ls -l $NETCDF | sed 's/ */ /g'`" - done - if [ "`echo $NETCDF | grep '..'`" != "" ] ; then - buff="`echo $NETCDF | sed -e 's/^\///' -e 's/\// /g'`" - n=`echo $buff | wc -w` - i=1 - while [ $i -le $n ] - do - if [ "`echo $buff | cut -d' ' -f$i`" = ".." ] ; then - m=$i - fi - i=$(( $i + 1 )) - done - m=$(( $m + 1 )) - NETCDF=/"`echo $buff | cut -d' ' -f${m}- | sed 's/ */\//g'`" - fi - if [ "${DEP_LIB_PATH#${DEP_LIB_PATH%?}}" = "/" ] ; then - DEP_LIB_PATH=`echo $DEP_LIB_PATH | sed 's/\/$//'` + NETCDF4_DEP_LIB='' + if [ "$NETCDF_C" != "NOT_FOUND" -a -f $NETCDF_C/bin/nc-config ] ; then + nx_config="`$NETCDF_C/bin/nc-config --libs`" + NETCDF4_DEP_LIB="$NETCDF4_DEP_LIB $nx_config" + else + echo ' ' + echo '*****************************************************************************' + echo 'WARNING! Unable to find nc-config. Linking with NetCDF may fail.' + echo '*****************************************************************************' + echo ' ' fi - DEP_LIB_PATH="`echo $DEP_LIB_PATH | awk -v VAR=-L$NETCDF/lib '{for(i=1;i<=NF;i++){if ($i != VAR ) {print $i} } }'`" + nx_config="`$NETCDF/bin/nf-config --flibs`" + NETCDF4_DEP_LIB="$NETCDF4_DEP_LIB $nx_config" fi fi @@ -398,12 +364,12 @@ else unset WRFPLUS_DIR fi fi -# Users who are cross-compiling can set environment variable -# $WRF_OS to override the value normally obtained from `uname`. -# If $WRF_OS is set, then $WRF_MACH can also be set to override -# the value normally obtained from `uname -m`. If $WRF_OS is -# set and $WRF_MACH is not set, then $WRF_MACH defaults to "ARCH". -# If $WRF_OS is not set then $WRF_MACH is ignored. +# Users who are cross-compiling can set environment variable +# $WRF_OS to override the value normally obtained from `uname`. +# If $WRF_OS is set, then $WRF_MACH can also be set to override +# the value normally obtained from `uname -m`. If $WRF_OS is +# set and $WRF_MACH is not set, then $WRF_MACH defaults to "ARCH". +# If $WRF_OS is not set then $WRF_MACH is ignored. if [ -n "$WRF_OS" ] ; then echo "${0}: WRF operating system set to \"${WRF_OS}\" via environment variable \$WRF_OS" os=$WRF_OS @@ -456,7 +422,7 @@ fi # the "!" is removed by Config.pl if [ -n "$WRF_HYDRO" ] ; then if [ $WRF_HYDRO = 1 ] ; then - echo building WRF-HYDRO + echo building WRF-HYDRO compileflags="${compileflags}!-DWRF_HYDRO" echo $compileflags fi @@ -517,11 +483,11 @@ if [ -n "$WRF_CHEM" ] ; then echo building WRF with chemistry option compileflags="${compileflags}!-DWRF_CHEM!-DBUILD_CHEM=1" if [ -n "$WRF_KPP" ] ; then - if [ $WRF_KPP = 1 ] ; then + if [ $WRF_KPP = 1 ] ; then echo building WRF with KPP chemistry option compileflags="${compileflags}!-DWRF_KPP" fi - fi + fi else compileflags="${compileflags} " fi @@ -575,7 +541,7 @@ if test -n "$PERL" ; then -netcdf=$NETCDF -pnetcdf=$PNETCDF -netcdfpar=$NETCDFPAR -adios2=$ADIOS2 -hdf5=$HDF5 -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -USENETCDF=$USENETCDF \ -time=$FORTRAN_COMPILER_TIMER -tfl="$TFL" -cfl="$CFL" -config_line="$config_line" \ - -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -dep_lib_path="$DEP_LIB_PATH" + -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -netcdf4_dep_lib="$NETCDF4_DEP_LIB" if test ! -f configure.wrf ; then echo "configure.wrf not created! Exiting configure script..." exit 1 @@ -620,7 +586,7 @@ if test -f configure.wrf ; then if [ "$os" = "Darwin" ] ; then # fseeko64 does not exist under Darwin fseeko does. Remove the 0 length executable # file that might get generated anyway, even though the compiler complains about missing reference. - /bin/rm -f tools/fseeko64_test + /bin/rm -f tools/fseeko64_test fi if test -x tools/fseeko64_test ; then ( tools/fseeko64_test 2> /dev/null ) 1> /dev/null @@ -665,7 +631,7 @@ if test -n "$NETCDF" ; then configure_aaaa=$? ; export configure_aaaa if [ $configure_aaaa -a -z "$WRFIO_NCD_NO_LARGE_FILE_SUPPORT" ] ; then echo "NetCDF users note:" - echo " This installation of NetCDF supports large file support. To DISABLE large file" + echo " This installation of NetCDF supports large file support. To DISABLE large file" echo " support in NetCDF, set the environment variable WRFIO_NCD_NO_LARGE_FILE_SUPPORT" echo " to 1 and run configure again. Set to any other value to avoid this message." fi @@ -690,10 +656,10 @@ if [ -n "$WRFPLUS" ] ; then fi fi -#Checking cross-compiling capability for some particular environment +#Checking cross-compiling capability for some particular environment #on Linux and Mac box -if [ $os = "Linux" -o $os = "Darwin" ]; then +if [ $os = "Linux" -o $os = "Darwin" -o $os = "CYGWIN_NT" ]; then SFC=`grep '^SFC' configure.wrf | awk '{print $3}'` SCC=`grep '^SCC' configure.wrf | awk '{print $3}'` @@ -724,7 +690,7 @@ EOF rm ${foo} ${foo}.F 2> /dev/null fi -cat > ${foo}.c < ${foo}.c < ${foo}.o + ar p $NETCDF_C/lib/libnetcdf.a `ar t $NETCDF_C/lib/libnetcdf.a | grep -E '\.o' | head -n 1 | sed 's/://'` > ${foo}.o netcdf_arch="`file ${foo}.o | grep -o -E '[0-9]{2}-bit|i386'`" rm ${foo}.o - $SFC -o ${foo} ${foo}.f > /dev/null 2>&1 + $SFC -o ${foo} ${foo}.f > /dev/null 2>&1 SFC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" rm ${foo} ${foo}.o 2> /dev/null @@ -790,7 +756,7 @@ EOF if [ "$SFC_arch" = "" -o "$SCC_arch" = "" -o "$CCOMP_arch" = "" ]; then echo " One of compilers testing failed!" echo " Please check your compiler" - echo + echo rm -f ${foo} ${foo}.[cfo] 2> /dev/null exit else @@ -901,14 +867,14 @@ EOF echo Please check your NetCDF lib and compiler else echo -m64 is appended to configure.wrf - echo It will be forced to build in 64-bit. + echo It will be forced to build in 64-bit. echo If you don\'t want 64-bit binaries, please use 32-bit NetCDF, and re-run the configure script. fi fi ;; esac - if [ -e configure.wrf.edit ]; then + if [ -e configure.wrf.edit ]; then mv configure.wrf.edit configure.wrf fi @@ -918,10 +884,10 @@ EOF echo " Fortran compiler is $SFC_arch" echo " It will build in $netcdf_arch" echo " " - if [ -e $NETCDF/bin/nc-config ] ; then + if [ -e $NETCDF_C/bin/nc-config ] ; then echo "NetCDF version: ${ncversion}" - echo "Enabled NetCDF-4/HDF-5: `nc-config --has-nc4`" - echo "NetCDF built with PnetCDF: `nc-config --has-pnetcdf`" + echo "Enabled NetCDF-4/HDF-5: `$NETCDF_C/bin/nc-config --has-nc4`" + echo "NetCDF built with PnetCDF: `$NETCDF_C/bin/nc-config --has-pnetcdf`" if [ "$USENETCDFPAR" = "1" ] ; then echo "Using parallel NetCDF via NETCDFPAR option" fi diff --git a/configure_new b/configure_new new file mode 100755 index 0000000000..e9d9900ba1 --- /dev/null +++ b/configure_new @@ -0,0 +1,84 @@ +#!/bin/sh + +help() +{ + echo "./configure_new [options] [-- ]" + echo " -p Preselect a stanza configuration with matching description" + echo " -x Skip CMake options prompt, meant to be used in conjunction with direct pass-in options" + echo " -d directory Use as alternate build directory" + echo " -i directory Use as alternate install directory" + echo " -- Directly pass CMake options to configuration, equivalent to cmake " + echo " -h Print this message" + +} + +preselect= +skipCMake=false +while getopts p:xd:i:h opt; do + case $opt in + p) + preselect=$OPTARG + ;; + x) + skipCMake=true + ;; + d) + buildDirectory=$OPTARG + ;; + i) + installDirectory=$OPTARG + ;; + h) help; exit 0 ;; + *) help; exit 1 ;; + :) help; exit 1 ;; + \?) help; exit 1 ;; + esac +done + +shift "$((OPTIND - 1))" + +extraOps= +if [ $skipCMake = true ]; then + extraOps="-x" +else + extraOps="-s CMakeLists.txt" +fi + +if [ -z "$buildDirectory" ]; then + buildDirectory=_build + echo "Using default build directory : $buildDirectory" +fi +if [ -z "$installDirectory" ]; then + installDirectory=$PWD/install + echo "Using default install directory : $installDirectory" +fi + +mkdir -p $buildDirectory + +if [ ! -z "$preselect" ]; then + echo "Using preselected config ${preselect}" + # Meant to be run at the top level + ./arch/configure_reader.py \ + -c arch/configure.defaults \ + -t cmake/template/arch_config.cmake \ + -o $buildDirectory/wrf_config.cmake \ + ${extraOps} -p "${preselect}" +else + # Meant to be run at the top level + ./arch/configure_reader.py \ + -c arch/configure.defaults \ + -t cmake/template/arch_config.cmake \ + -o $buildDirectory/wrf_config.cmake \ + ${extraOps} +fi + +configureStanza=$? + +if [ $configureStanza -eq 0 ]; then + # Now run cmake + cd $buildDirectory + cmake .. -DCMAKE_INSTALL_PREFIX=$installDirectory -DCMAKE_TOOLCHAIN_FILE=$buildDirectory/wrf_config.cmake $* + exit $? +else + exit $configureStanza +fi \ No newline at end of file diff --git a/doc/README.NSSLmp b/doc/README.NSSLmp new file mode 100644 index 0000000000..e9b673653e --- /dev/null +++ b/doc/README.NSSLmp @@ -0,0 +1,165 @@ +Some background information and usage tips for the NSSL microphysics scheme. + + + IMPORTANT: Best results are attained using WENO (Weighted Essentially Non-Oscillatory) scalar advection option. This helps to limit oscillations at the edges of precipitation regions (i.e., sharp gradient), which in turns helps to prevent mismatches of moments that can show up as noisy reflectivity values. + moist_adv_opt = 4, + scalar_adv_opt = 3, + The monotonic option (2) is less effective, but better than the default positive definite option (1) + +NOTE TO SMPAR or DM+SMPAR USERS: If a segmentation fault occurs, try setting the environment variable OMP_STACKSIZE to 8M or 16M (default is 4M, where M=MB). Note that this does not increase the shell stacksize limit [use 'ulimit -a unlimited' (bash) or 'unlimit stacksize' (tcsh)] + +CHANGES: +June 2023 (WRF 4.6): Main default option change is for graupel/hail fall speed options (icdx, icdxhl; changed from 3 to 6, see below), and default maximum gr/hail droplet collection efficiencies (ehw0/ehlw0 changed from 0.5/0.75 to 0.9/0.9, see below). Snow aggregation efficiency is reduced to limit excessive snow reflectivity (see below). + +CONTACT: For questions not covered here (or other issues/bugs), feel free to contact Ted Mansell (NOAA/NSSL) at ted.mansell_at_noaa.gov and/or tag @MicroTed in a github issue. + +DESCRIPTION: + +The NSSL bulk microphysical parameterization scheme describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) and Mansell and Ziegler (2013). It is designed with deep (severe) convection in mind at grid spacings of up to 4 km, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather. The scheme predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. The 3-moment option additionally predicts the 6th moments of rain, graupel, and hail which in turn predicts the PSD shape parameters (set nssl_3moment=.true.). + +Basic options in physics namelist: + mp_physics = 18 ! NSSL scheme (2-moment) with hail and predicted + CCN concentration + options + + The legacy options (17,19,21,22) still behave as before (for now), but going + forward one should use mp_physics=18 with modifier flags: + + mp_physics + = 22 ! NSSL scheme (2-moment) without hail + Equivalent: mp=18, nssl_hail_on=0, nssl_ccn_on=0 + = 17 ! NSSL scheme (2-moment) with hail with constant background CCN + concentration + Equivalent: mp=18, nssl_ccn_on=0 + = 19, NSSL 1-moment (7 class: qv,qc,qr,qi,qs,qg,qh; predicts graupel density) + Equivalent: mp=18, nssl_2moment_on=0, nssl_ccn_on=0 (do no set nssl_hail_on) + = 21, NSSL 1-moment, (6-class), very similar to Gilmore et al. 2004 + Equivalent: mp=18, nssl_2moment_on=0, nssl_hail_on=0, nssl_ccn_on=0, + nssl_density_on=0 + +Option flags (integer; apply to all domains except nssl_hail_on): + + nssl_3moment : default value of 0, setting to 1 adds 6th moment for rain, + graupel (i.e., 3-moment ) and hail (Only needed for turning + 3-moment on) + + nssl_density_on : default value of 1; Setting to 0 turns off graupel/hail predicted + ice density and instead uses fixed (constant) ice density + for graupel (nssl_rho_qh, default 500.) and hail (nssl_rho_qhl, + default 800.) (Only needed for turning density off) + + nssl_ccn_on : predicted CCN concentration: default is on (1) for mp_physics=18 + + nssl_hail_on : If not set explicitly, it is set automatically to 1. This is the only + flag with dimensions of 'max_domains' e.g., so that hail can be turned + off on non-convection-allowing parent domains (Default is on, so this + is only needed for turning the hail species off) + + nssl_ccn_is_ccna : The CCN category, if enabled (=1), can be used to represent either the + number of unactivated CCN (default, value of 0, with irenuc=2), or, if + set to 1, it is CCNA (the number of activated CCN, background value + of zero). If irenuc >= 5 (see below), this is automatically set to 1. + + nssl_2moment_on : only use this flag to run single-moment (value of 0), otherwise + default is 1 (Only needed for turning 2-moment off) + + Other namelist options (also "physics" namelist) + nssl_alphah = 0. ! PSD shape parameter for graupel (1- and 2-moment) + nssl_alphahl = 1. ! PSD shape parameter for hail (1- and 2-moment) + nssl_cnoh = 4.e5 ! graupel intercept (1-moment only) + nssl_cnohl = 4.e4 ! hail intercept (1-moment only) + nssl_cnor = 8.e5 ! rain intercept (1-moment only) + nssl_cnos = 3.e6 ! snow intercept (1-moment only) + nssl_rho_qh = 500. ! graupel density (nssl_density_on=0) + nssl_rho_qhl = 800. ! hail density (nssl_density_on=0) + nssl_rho_qs = 100. ! snow density + + + nssl_cccn - (real) Initial concentration of cloud condensation + nuclei (per m^3 at sea level) + 0.25e+9 maritime + 0.5e+9 "low-med" continental (DEFAULT) + 1.0e+9 "med-high" continental + 1.5e+09 - high-extreme continental CCN) + Larger values run a risk of unrealistically weak + precipitation production + The value of nssl_cccn sets the concentration at MSL, and an initially + homogeneous number mixing ratio (ccn/1.225) is assumed throughout + the depth of the domain. The droplet concentration near cloud base + will be less than nssl_cccn because of the well-mixed assumption, + so if a target Nc is desired, set nssl_cccn higher by a factor of + 1.225/(air density at cloud base). + +The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel that is actively riming (esp. in wet growth). + +Hydrometeor size distributions are assumed to follow a gamma functional form. (Shape parameters for 2-moment graupel and hail can be set with nssl_alphah/nssl_alphahl.) Microphysical processes include cloud droplet and cloud ice nucleation, condensation, deposition, evaporation, sublimation, collection–coalescence, variable-density riming, shedding, ice multiplication, cloud ice aggregation, freezing and melting, and conversions between hydrometeor categories. + +Cloud concentration nuclei (CCN) concentration is predicted as in Mansell et al. (2010) with a bulk activation spectrum approximating small aerosols. (New option nssl_ccn_is_ccna=1 instead predicts the number of activated CCN.) The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present (ccntimeconst). Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration. + +Droplet activation option method is controlled by the 'irenuc' option (internal to NSSL module). The default option (2) depletes CCN from the unactivated CCN field. A new option (7) instead counts the number of activated CCN (nucleated droplets) with the assumption of an initial constant CCN number mixing ratio. Option 7 better handles supersaturation at low CCN (e.g., maritime) concentrations by allowing extra droplet activation at high SS. + + irenuc : (nssl_mp_params namelist) + 2 = ccn field is UNactivated aerosol (default; old droplet activation) + Can switch to counting activated CCN with nssl_ccn_is_ccna=1 + 7 = ccn field must be ACTVIATED aerosol (new droplet activation) + Must have nssl_ccn_on=1 for irenuc=7 + +Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010). For 2-moment, infall=4 (default; nssl_mp_params namelist) is recommended. For 3-moment, infall only really applies to droplets, cloud ice, and snow. + +Graupel -> hail conversion: The parameter ihlcnh selects the method of converting graupel (hail embryos) to the hail category. The default value is -1 for automatic setting. The original option (ihlcnh=1) is replaced by a new option (ihlcnh=3) as of May 2023. ihlcnh=3 converts from the graupel spectrum itself based on the wet growth diameter, which generally results in fewer initiated hailstones with larger diameters (and larger mean diameter at the ground). If hail size seems excessive, try setting ihlcnh=1, which tends to generate higher hail number concentrations and thus smaller diameters. + +The June 2023 (WRF 4.6) update introduces changes in the default options for graupel/hail fall speeds and collection efficiencies. The original fall speed options (icdx=3; icdxhl=3) from Mansell et al. (2010) are switched to the Milbrandt and Morrison (2013) fall speed curves (icdx=6; icdxhl=6). Because the fall speeds are generally a bit lower, a partially compensating increase in maximum collection efficiency is set by default: ehw0/ehlw0 increased to 0.9. One effect is somewhat reduced total precipitation and cold pool intensity for supercell storms. + + (nssl_mp_params namelist) + icdx - fall speed option for graupel (was 3, now is 6) + icdxhl - fall speed option for hail (was 3, now is 6) + ehw0,ehlw0 - Maximim droplet collection efficiencies for graupel (ehw0=0.75, now 0.9) + and hail (ehlw0=0.75, now 0.9) + ihlcnh - graupel to hail conversion option (was 1, now 3) + +In summary, to get something closer to previous behavior, use the following: + +&nssl_mp_params + icdx = 3 + icdxhl = 3 + ehw0 = 0.5 + ehlw0 = 0.75 + ihlcnh = 1 +/ + +Snow Aggregation and reflectivity: + +Snow self-collection (aggregation) has been curbed in the 4.6 version by reducing the collision efficiency and the temperature range over which aggregation is allowed (esstem): + + ess0 = 0.5 ! collision efficiency, reduced from 1 to 0.5 + esstem1 = -15. ! was -25. ! lower temperature where snow aggregation turns on + esstem2 = -10. ! was -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + + If desired, some further reduction in aggregation can be gained from setting iessopt=4, which reduces ess0 to 0.1 (80% reduction) in conditions of ice subsaturation (RHice < 100%). + Snow reflectivity formerly had a default setting that turned on a crude bright band enhancement (iusewetsnow=1). This is now turned off by default (iusewetsnow=0) + These snow parameters can be accessed through the nssl_mp_params namelist. + +References: + +Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification + of a small thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., + 67, 171-194, doi:10. 1175/2009JAS2965.1. + +Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm + electrification and precipitation in a two-moment bulk microphysics model. + J. Atmos. Sci., 70 (7), 2032-2050, doi:10.1175/JAS-D-12-0264.1. + +Mansell, E. R., D. T. Dawson, J. M. Straka, Bin-emulating Hail Melting in 3-moment + bulk microphysics, J. Atmos. Sci., 77, 3361-3385, doi: 10.1175/JAS-D-19-0268.1 + +Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed + convective storms. Part I: Model development and preliminary testing. J. + Atmos. Sci., 42, 1487-1509. + +Sedimentation reference: + +Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. + J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. + + + + diff --git a/doc/README.cmake_build b/doc/README.cmake_build new file mode 100644 index 0000000000..d11c248cf6 --- /dev/null +++ b/doc/README.cmake_build @@ -0,0 +1,229 @@ + +How to compile and run? +----------------------- + +- In WRF directory, type './configure_new' - this will create a + _build/wrf_config.cmake file that has appropriate compile options for the + supported computers. + + Note: !! You must clone all submodules manually and have all code prepared !! + !! to compile. No extra steps are done to download code or sanitize it !! + + Note: WRF requires netCDF library, but this cmake build does not require you + to set any environment variables. For netCDF detection, the configuration + will be detected from the `nc-config` in your path unless using + netCDF_ROOT cmake variable. See more information from cmake on *_ROOT + variables if you do not want to use the netCDF associated with the + `nc-config` in your path + + Follow the prompts to select your configuration. The first will be a general + stanza selection, which will only show configurations for which you have the + supported compilers in your path. Likewise, for partially supported stanzas + a '!!' will appear next to that portion of the stanza denoting that this + portion of the stanza is not supported in your environment and thus will not + be selectable via the interactive dialogs. + + Compared to previous version of `configure` this will look much more sparse + and the numbering will be changed to reflect what is availble. For this + reason it will be best to talk about configuration with their description + or some other unique identifier from now on with this build methodology. + + Other common options previously done during the stanza configuration selection + are now broken out into y/n interactive queries. This includes usage of : + * SM (OpenMP) + * DM (MPI) + + Target selection (case), core, and nesting are all done at the configuration phase. + + Any extra configuration parameters that would normally be done through + environment variables or extra command line options are under the + "Configure additional options?" section + + Advanced features of `./configure_new` are discussed later in this document + +- Type './compile_new [any make options such as `-j 12`]' + If the first argument to compile_new is a directory, it will instead use that + directory as the location for building. If not the default is to build the + configuration placed in _build (the default location for `./configure_new` to + place a configuration) + + +- If sucessful, this will create either `real` or `ideal` and `wrf` executables + in the install location's bin/ directory (for default location this will be + install/bin/) and the appropriate executables will be also copied into + the respective test directoires under the same install directory as + /test/. Likewise, for specific test cases that + have additional or modified inputs, those input files are copied from the + respective source location test/ + + Note: Compared to the older compile script, executables do not have the '.exe' + suffix + +- cd to the appropriate test directory in the installation location to run + ideal/real/wrf. + +- If it is one of the idealized cases (b_wave, hill2d_x, grav2d_x, quarter_ss, + squall2d_x, squall2d_y, em_les or em_heldsuarez), cd the the appropriate directory, type + + ./ideal + + to produce wrfinput_d01 file for wrf model. Then type + + ./wrf + + to run. + +- If it is real-data case (real), place files from WPS (met_em.*) + in the appropriate directory, type + + ./real + + to produce wrfbdy_d01 and wrfinput_d01. Then type + + ./wrf + + to run. + +- If you use mpich, type + + mpirun -np number-of-processors wrf + +- If you want to clean your configuration use `./cleanCMake.sh`, additional + options are available, see `./cleanCMake.sh -h` for more info + + +Advanced Configuration +----------------------- + +- The 'configure_new' script is designed to work out-of-the-box with minimal + guidance, however to take full advantage of the features this system brings + one can use `./configure_new -h` to receive a help message: + ./configure_new [options] [-- ] + -p Preselect a stanza configuration with matching description + -x Skip CMake options prompt, meant to be used in conjunction with direct pass-in options + -d directory Use as alternate build directory + -i directory Use as alternate install directory + -- Directly pass CMake options to configuration, equivalent to cmake + -h Print this message + + The '-p' option allows the preselection of a stanza based on its description + without requiring knowledge about its defined number within your environment. + This does require that the stanza exist within the compatible set that would + be available within your environment. + + The '-x' option allows the interactive dialogs to be suppressed, and + configuration will immediately proceed with whatever options have been set or + passed in. This is meant to be used with the '--' delimeter option + + The '-d' option allows us to specify an alternative build/configuration + directory. As CMake best operates with out-of-source builds, our configuration + and compilation all happen within a different directory than the source. The + default name of this directory is _build/, however for more fine-tuned control + or housing multiple builds from the same source repo at the same time one can + specify a different directory name using this option. It is recommended to use + _build* as the prefix to denote this as an autogenerated directory that can be + safely deleted in its entirety + + The '-i' options allows us to specify an alternative install directory for our + compiled configuration. The default value is $PWD/install. Note that the + default includes '$PWD/' - directory locations provided via this option should + use absolute paths as the compile command is executed inside the build + directory, thus any relative paths would be from that location. The files to + be placed in the install directory follows the same premises as the '-d' + option meaning they are autogenerated or copies of source files. This means + the install directory can be safely deleted in its entirety if this + configuration is no longer desired. This also allows multiple installs of + different compilations to coexist from within the same source repo + + The '--' option is meant to be a delimeter marking all subsequent input to be + fed directly to the CMake command execution. In other words, after this marker + anything that you place afterwards is as if you are directly passing in + command line options to `cmake`. This allows you to more effectively use the + '-x' option to skip interactive dialogs and instead write the value you want + beforehand, though usage of this option is not necessary. The option name and + values for a given option, respectively, are always named the same as the + cmake option so utilizing the same option name and value that appears in + the interactive dialog will work. As an example : + + ./configure_new -p GNU -x -- -DWRF_CORE=ARW -DWRF_NESTING=BASIC -DWRF_CASE=EM_REAL + + Would configure immediately configure for the first GNU stanza, using "ARW" as + the WRF_CORE option, "BASIC" as the WRF_NESTING option, and "EM_REAL" as the + WRF_CASE option. Note that the value used is the actual name of the value, not + the numeric shorthand used during interactive dialog. + + +- The 'compile_new' has a complimentary feature to pair with 'configure_new'. + This feature is specifying an alternate build directory to use as a compile + location. The alternate install directory, if used, does not need to be + specified as that is embedded into the cmake configuration files at configure + time. To use this feature, specify the alternate build directory to use as the + first argument ONLY into the script, like so : + + ./configure_new _buildCustomDirectory -j 12 + + Afterwards, all standard make options apply. If no directory is provided it + will be assumed that you are using the default build directory '_build'. This + should be sufficient for normal usage. + + +- The 'cleanCmake.sh' is a cleaning script to more easily facilitate cleaning + configurations, whether configured, compiled, or installed. To see the full + list of options, use `./cleanCmake.sh -h` to receive a help message: + + ./cleanCMake.sh [options] + -c [Default if no options] Basic cmake clean functionality [make -j 1 clean] + -b Remove cmake binary installs [xargs rm < _build/install_manifest.txt] + -f Remove build & install folders (WRF) [ rm _build -r; rm install/ -r ] + -a Remove all (WRF), equivalent to -c -b -f (more specifically -c then -b then -f)" + Specific builds/installs + -d directory Specify operating on particular build directory + -i directory Specify operating on particular install directory + + Each command tells exactly or the equivalent shell commands that would be + executed, but for clarity they are explained below as well. + + The '-c' option is the default usage if no options were passed in, in other + words `./cleanCmake.sh`. This effectively goes into the build directory and + runs `make -j 1 clean`, removing all binary objects in the build directory. + This does not remove files in the install directory. + + The '-b' option removes the installed files from the install directory + manually. This can be useful for reinstating a faulty or manually disrupted + install without needing to entirely recompile. For example, imagine modifying + the provided 'namelist.input' in the test case folder of the install, but not + recalling what the original values were and where the file originates from. + One could clean only the install and reinstall the exact same compilation with + `./cleanCMake.sh -b && ./compile_new` to reobtain a pristine install. + + The '-f' option removes the build and install directories entirely. This is + quickest way to clean but also lose a configuration. It can be very useful if + you find your configuration not working as expected and need a full reset. + This can often happen with CMake caching, which can be a headache to clear. + + The '-a' option can be seen as an alternative to the '-f' option which + effectively in the end does the same but in a more ordered fashion. This will + perform all the cleaning in a step-by-step process first doing the '-c' option, + then the '-b' option, and finally the '-f'. + + + Additional functionality is provided to compliment the advanced features in + 'configure_new' of '-d'/'-i'. These are mimicked in 'cleanCMake.sh' to have + the same usage and flags, so interchanging then between the commands will work. + The effects of 'cleanCMake.sh' cleaning, based on option, will + correspondingly affect the newly specified directories. For example, if an + alternate build directory is provided, the '-b' option will use that instead: + + ./cleanCMake.sh -b -d _buildCustomDirectory + + One might think we would use the install directory when specifying the '-b' + option, but recall that the install location is embeded into the build + configuration and thus removing the installs that cmake did without entirely + removing the install directory requires going to the build directory. This + can be extremely versatile when installing into common locations where other + projects or installed software coexists within a single base install folder. + + + + + diff --git a/doc/README.cygwin.md b/doc/README.cygwin.md index 1d8599e951..3c5b45461d 100644 --- a/doc/README.cygwin.md +++ b/doc/README.cygwin.md @@ -17,11 +17,28 @@ - gcc-core (OpenMP for smpar) - gcc-fortran - libnetcdf-fortran-devel + - libnetcdf-devel + - libhdf5-devel + - zlib-devel - openmpi (MPI for dmpar) - libopenmpi-devel (MPI for dmpar) + - libhwloc-devel (MPI for dmpar) + - libevent-devel (MPI for dmpar) - libjasper-devel (GRIB) - perl + - perl_base - tcsh + - m4 + - make + - libtirpc-devel + - sed + - gawk + - tar + - gzip + - coreutils + - which + - file + - grep - Select install - Accept the packages pulled in as dependencies - Wait for download, install, and postinstall steps. This will diff --git a/doc/README.netcdf4par b/doc/README.netcdf4par index a4f50e1a07..e40edb9240 100644 --- a/doc/README.netcdf4par +++ b/doc/README.netcdf4par @@ -41,4 +41,4 @@ Performance seems to vary with how 'regular' the domain decomposition is (i.e., patch size). Some experimentation with manually setting the decomposition may be needed for optimal writing times. Also pay attention to file system striping (Lustre), where setting the number stripes should not exceed the -number of nodes used by the job. \ No newline at end of file +number of nodes used by the job. diff --git a/dyn_em/CMakeLists.txt b/dyn_em/CMakeLists.txt new file mode 100644 index 0000000000..bff8b38e5d --- /dev/null +++ b/dyn_em/CMakeLists.txt @@ -0,0 +1,45 @@ +# WRF CMake Build +target_include_directories( + ${PROJECT_NAME}_Core + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +######################################################################################################################## +# +# Now add sources +# +######################################################################################################################## +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + module_advect_em.F + module_ieva_em.F + module_diffusion_em.F + module_small_step_em.F + module_big_step_utilities_em.F + module_em.F + module_solvedebug_em.F + module_bc_em.F + module_init_utilities.F + module_wps_io_arw.F + module_damping_em.F + module_polarfft.F + module_force_scm.F + module_first_rk_step_part1.F + module_first_rk_step_part2.F + module_avgflx_em.F + module_sfs_nba.F + module_convtrans_prep.F + module_sfs_driver.F + module_stoch.F + module_after_all_rk_steps.F + init_modules_em.F + solve_em.F + start_em.F + shift_domain_em.F + couple_or_uncouple_em.F + nest_init_utils.F + adapt_timestep_em.F + interp_domain_em.F + ) diff --git a/dyn_em/module_advect_em.F b/dyn_em/module_advect_em.F index ff03d1a695..b8cf8988d6 100644 --- a/dyn_em/module_advect_em.F +++ b/dyn_em/module_advect_em.F @@ -1,7 +1,7 @@ !WRF:MODEL_LAYER:DYNAMICS ! -#if ( defined(ADVECT_KERNEL) ) +#ifdef ADVECT_KERNEL ! cpp -traditional-cpp -P -DADVECT_KERNEL module_advect_em.F > advection_kernel.f90 ! gfortran -ffree-form -ffree-line-length-none advection_kernel.f90 ! ./a.out @@ -111,7 +111,7 @@ SUBROUTINE column (loop , data_list, its,ite) END SUBROUTINE column !---------------------------------------------------------------- -#elif ( ! defined(ADVECT_KERNEL) ) +#else MODULE module_advect_em @@ -4146,8 +4146,8 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & IF( (config_flags%open_ys) .and. (jts == jds) ) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -4162,8 +4162,8 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & IF( (config_flags%open_ye) .and. (jte == jde)) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -4357,7 +4357,7 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & ENDIF vert_order_test END SUBROUTINE advect_scalar -#if ( ! defined(ADVECT_KERNEL) ) +#ifndef ADVECT_KERNEL !--------------------------------------------------------------------------------- @@ -4620,14 +4620,14 @@ SUBROUTINE advect_w ( w, w_old, tendency, & ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) @@ -4934,14 +4934,14 @@ SUBROUTINE advect_w ( w, w_old, tendency, & ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) @@ -5293,14 +5293,14 @@ SUBROUTINE advect_w ( w, w_old, tendency, & ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) @@ -5525,14 +5525,14 @@ SUBROUTINE advect_w ( w, w_old, tendency, & ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) @@ -7297,8 +7297,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%open_ys) .and. (jts == jds) ) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -7313,8 +7313,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%open_ye) .and. (jte == jde)) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7330,8 +7330,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%polar) .and. (jts == jds) ) THEN ! Assuming rv(i,k,jds) = 0. - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*rv(i,k,jts+1), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -7347,8 +7347,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%polar) .and. (jte == jde)) THEN ! Assuming rv(i,k,jde) = 0. - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*rv(i,k,jte-1), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7412,6 +7412,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7424,6 +7427,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7436,6 +7442,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7485,6 +7494,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7497,6 +7509,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7509,6 +7524,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7956,7 +7974,7 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk - double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-28 + double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-40 integer, parameter :: pw = 2 @@ -8652,7 +8670,7 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & real :: qim2, qim1, qi, qip1, qip2 double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk - double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-28 + double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-40 integer, parameter :: pw = 2 @@ -10543,7 +10561,7 @@ END SUBROUTINE advect_scalar_mono !----------------------------------------------------------- -#if ( defined(ADVECT_KERNEL) ) +#ifdef ADVECT_KERNEL END MODULE advection_kernel !================================================================ @@ -10851,7 +10869,7 @@ PROGRAM feeder END PROGRAM feeder #endif -#if ( !defined(ADVECT_KERNEL) ) +#ifndef ADVECT_KERNEL !--------------------------------------------------------------------------------- @@ -12541,14 +12559,14 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) END DO END DO ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf + DO k=kts+1,ktf+1 DO i = i_start, i_end mrdy=msftx(i,j-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) diff --git a/dyn_em/module_big_step_utilities_em.F b/dyn_em/module_big_step_utilities_em.F index 50d7972c62..72e827b275 100644 --- a/dyn_em/module_big_step_utilities_em.F +++ b/dyn_em/module_big_step_utilities_em.F @@ -5105,8 +5105,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (config_flags%cu_physics .gt. 0) THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) @@ -5116,8 +5116,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5126,8 +5126,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5136,8 +5136,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5146,8 +5146,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5156,8 +5156,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5169,8 +5169,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (config_flags%shcu_physics .gt. 0) THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RTHSHTEN(I,K,J)=RTHSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) @@ -5180,8 +5180,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQVSHTEN(I,K,J)=RQVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5190,8 +5190,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQCSHTEN(I,K,J)=RQCSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5200,8 +5200,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQRSHTEN(I,K,J)=RQRSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5210,8 +5210,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQISHTEN(I,K,J)=RQISHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5220,8 +5220,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5230,8 +5230,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQGSHTEN(I,K,J)=RQGSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5296,8 +5296,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5312,8 +5312,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ( config_flags%cu_physics == NTIEDTKESCHEME )) THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5322,8 +5322,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ! If using moist theta, get dry theta tendency for CPSs IF ( config_flags%use_theta_m == 1 ) THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end th_phy(i,k,j) = (t_new(i,k,j) + t0) / (1. + (R_v/R_d) * qv(i,k,j)) rthften(i,k,j) = th_phy(i,k,j)/(t_new(i,k,j)+t0) * & (rthften(i,k,j) - (R_v/R_d) * th_phy(i,k,j) * rqvften(i,k,j)) diff --git a/dyn_em/module_diffusion_em.F b/dyn_em/module_diffusion_em.F index 2a2db2b5c9..21d602fda9 100644 --- a/dyn_em/module_diffusion_em.F +++ b/dyn_em/module_diffusion_em.F @@ -3023,7 +3023,7 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & config_flags, & tke(ims,kms,jms), & msftx, msfty, msfux, msfuy, & - msfvx, msfvy, xkhh, rdx, rdy, & + msfvx, msfvy, xkmh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & zx, zy, rdz, rdzw, dnw, dn, rho, & .true., & @@ -4332,7 +4332,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & If (km_opt .eq. 2) then CALL vertical_diffusion_s( tke_tendf(ims,kms,jms), & config_flags, tke(ims,kms,jms), & - xkhv, & + xkmv, & dn, dnw, rdz, rdzw, fnm, fnp, rho, & .true., & ids, ide, jds, jde, kds, kde, & @@ -8157,7 +8157,7 @@ SUBROUTINE vertical_diffusion_implicit(ru_tendf, rv_tendf, rw_tendf, rt_tendf,& DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) & + xkxavg(i,k,j) = ( fnm(k) * 2. * xkmv(i,k,j) + fnp(k) * 2. * xkmv(i,k-1,j) ) & *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) ) END DO END DO diff --git a/dyn_em/module_em.F b/dyn_em/module_em.F index b71934b641..56df890f90 100644 --- a/dyn_em/module_em.F +++ b/dyn_em/module_em.F @@ -2208,8 +2208,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (config_flags%cu_physics .gt. 0) THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RUCUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RUCUTEN(I,K,J) RVCUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RVCUTEN(I,K,J) RTHCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RTHCUTEN(I,K,J) @@ -2220,8 +2220,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQCCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQCCUTEN(I,K,J) ENDDO ENDDO @@ -2230,8 +2230,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQRCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQRCUTEN(I,K,J) ENDDO ENDDO @@ -2240,8 +2240,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQICUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQICUTEN(I,K,J) ENDDO ENDDO @@ -2250,8 +2250,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQSCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQSCUTEN(I,K,J) ENDDO ENDDO @@ -2265,8 +2265,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (config_flags%shcu_physics .gt. 0) THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RUSHTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RUSHTEN(I,K,J) RVSHTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RVSHTEN(I,K,J) RTHSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RTHSHTEN(I,K,J) @@ -2277,8 +2277,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQCSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQCSHTEN(I,K,J) ENDDO ENDDO @@ -2287,8 +2287,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQRSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQRSHTEN(I,K,J) ENDDO ENDDO @@ -2297,8 +2297,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQISHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQISHTEN(I,K,J) ENDDO ENDDO @@ -2307,8 +2307,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQSSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQSSHTEN(I,K,J) ENDDO ENDDO @@ -2317,8 +2317,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQGSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQGSHTEN(I,K,J) ENDDO ENDDO diff --git a/dyn_em/module_first_rk_step_part1.F b/dyn_em/module_first_rk_step_part1.F index f5eb26734d..6623cab7bd 100644 --- a/dyn_em/module_first_rk_step_part1.F +++ b/dyn_em/module_first_rk_step_part1.F @@ -644,6 +644,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics & & ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics ,SH2O=grid%sh2o & & ,SHDMAX=grid%shdmax ,SHDMIN=grid%shdmin ,SMOIS=grid%smois & + & ,SHDAVG=grid%shdavg & & ,SMSTAV=grid%smstav ,SMSTOT=grid%smstot ,SNOALB=grid%snoalb & & ,SNOW=grid%snow ,SNOWC=grid%snowc ,SNOWH=grid%snowh & & ,SMCREL=grid%smcrel & @@ -810,6 +811,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,urban_map_zgrd = config_flags%urban_map_zgrd & !multi-layer urban & ,NUM_URBAN_HI=config_flags%num_urban_hi & !multi-layer urban & ,use_wudapt_lcz=config_flags%use_wudapt_lcz & !wudapt + & ,slucm_distributed_drag=config_flags%slucm_distributed_drag & !SLUCM & ,TSK_RURAL=grid%tsk_rural & !multi-layer urban & ,TRB_URB4D=grid%trb_urb4d,TW1_URB4D=grid%tw1_urb4d & !multi-layer urban & ,TW2_URB4D=grid%tw2_urb4d,TGB_URB4D=grid%tgb_urb4d & !multi-layer urban @@ -846,7 +848,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,LB_URB2D=grid%lb_urb2d,HGT_URB2D=grid%hgt_urb2d & !multi-layer urban & ,MH_URB2D=grid%mh_urb2d,STDH_URB2D=grid%stdh_urb2d & !SLUCM & ,LF_URB2D=grid%lf_urb2d & + & ,lf_urb2d_s=grid%lf_urb2d_s, z0_urb2d=grid%z0_urb2d & & ,GMT=grid%gmt,XLAT=grid%xlat,XLONG=grid%xlong,JULDAY=grid%julday & + & ,distributed_ahe_opt=grid%distributed_ahe_opt, ahe=grid%ahe & !For anthropogenic heat & ,A_U_BEP=grid%a_u_bep,A_V_BEP=grid%a_v_bep,A_T_BEP=grid%a_t_bep & & ,A_Q_BEP=grid%a_q_bep & & ,B_U_BEP=grid%b_u_bep,B_V_BEP=grid%b_v_bep,B_T_BEP=grid%b_t_bep & @@ -925,7 +929,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,iopt_crop=config_flags%opt_crop, iopt_irr=config_flags%opt_irr & & ,iopt_irrm=config_flags%opt_irrm & & ,iopt_infdv=config_flags%opt_infdv,iopt_tdrn=config_flags%opt_tdrn & - & ,soiltstep=config_flags%soiltstep + & ,soiltstep=config_flags%soiltstep & & , isnowxy=grid%isnowxy , tvxy=grid%tvxy , tgxy=grid%tgxy & & ,canicexy=grid%canicexy ,canliqxy=grid%canliqxy, eahxy=grid%eahxy & & , tahxy=grid%tahxy , cmxy=grid%cmxy , chxy=grid%chxy & @@ -1109,6 +1113,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & AKHS=grid%akhs ,AKMS=grid%akms & & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics & & ,WINDFARM_OPT=config_flags%windfarm_opt,power=grid%power & + & ,windfarm_wake_model=config_flags%windfarm_wake_model & ! Yulong add for WLM + & ,windfarm_overlap_method=config_flags%windfarm_overlap_method & ! Yulong add for WLM & ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & & ,BLDTACTTIME=grid%bldtacttime & & ,BR=grid%br ,CHKLOWQ=chklowq ,CT=grid%ct & @@ -1155,6 +1161,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & ! Bep changes end ! add tke_pbl, and turbulent fluxes & ,TKE_PBL=grid%tke_pbl,EL_PBL=grid%el_pbl,WU_TUR=grid%wu_tur & + & , gmt=grid%gmt, xtime=grid%xtime,julday=grid%julday,julyr=grid%julyr & + & , ahe=grid%ahe,distributed_ahe_opt=grid%distributed_ahe_opt & & ,WV_tur=grid%wv_tur,WT_tur=grid%wt_tur,WQ_tur=grid%wq_tur & & ,DISS_PBL=grid%diss_pbl,TPE_PBL=grid%tpe_pbl & & ,TKE_ADV=scalar(ims,kms,jms,P_tke_adv) & @@ -1223,8 +1231,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,rmol=grid%rmol, ch=grid%ch & & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling & ! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q & - & ,vdfg=grid%vdfg,nupdraft=grid%nupdraft,maxMF=grid%maxmf & - & ,ktop_plume=grid%ktop_plume & + & ,vdfg=grid%vdfg,maxwidth=grid%maxwidth,maxMF=grid%maxmf & + & ,ztop_plume=grid%ztop_plume,ktop_plume=grid%ktop_plume & & ,spp_pbl=config_flags%spp_pbl & & ,pattern_spp_pbl=grid%pattern_spp_pbl & & ,restart=config_flags%restart,cycling=config_flags%cycling & diff --git a/dyn_em/module_initialize_real.F b/dyn_em/module_initialize_real.F index 96629232bf..d8663ca6f1 100644 --- a/dyn_em/module_initialize_real.F +++ b/dyn_em/module_initialize_real.F @@ -617,6 +617,15 @@ SUBROUTINE init_domain_rk ( grid & END IF END IF + IF (config_flags%slucm_distributed_drag) THEN + CALL wrf_message('Adding zero-plane displacement height to topography') + DO j = jts, MIN(jde - 1, jte) + DO i = its, MIN(ide - 1, ite) + IF (grid%zd_urb2d(i, j) > 0) grid%ht_gc(i, j) = grid%ht_gc(i, j) + grid%zd_urb2d(i, j) + END DO + END DO + END IF + ! Is there any vertical interpolation to do? The "old" data comes in on the correct ! vertical locations already. @@ -1101,6 +1110,7 @@ SUBROUTINE init_domain_rk ( grid & ELSE k = num_metgrid_levels END IF + config_flags%use_sh_qv = .FALSE. IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc , & @@ -1181,6 +1191,7 @@ SUBROUTINE init_domain_rk ( grid & END IF ! Some data sets do not provide a 3d geopotential height field. + ! This calculation is more accurate if the data is bottom-up. IF ( grid%ght_gc(i_valid,grid%num_metgrid_levels/2,j_valid) .LT. 1 ) THEN DO j = jts, MIN(jte,jde-1) @@ -1239,6 +1250,15 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF + IF ( flag_sh .EQ. 1 ) THEN + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%q2(i,j)=grid%qv_gc(i,1,j) + END DO + END DO + END IF + ! The requested ptop for real data cases. p_top_requested = grid%p_top_requested @@ -1330,6 +1350,11 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + CALL monthly_avg ( grid%greenfrac , grid%shdavg , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + ! The model expects the green-ness and vegetation fraction values to be in percent, not fraction. DO j = jts, MIN(jte,jde-1) @@ -1338,7 +1363,8 @@ SUBROUTINE init_domain_rk ( grid & grid%vegfra(i,j) = grid%vegfra(i,j) * 100. grid%shdmax(i,j) = grid%shdmax(i,j) * 100. grid%shdmin(i,j) = grid%shdmin(i,j) * 100. - END DO + grid%shdavg(i,j) = grid%shdavg(i,j) * 100. + END DO END DO ! The model expects the albedo fields as a fraction, not a percent. Set the @@ -1708,6 +1734,23 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + ! when specific humidity is available, qv_gc is computed from sh_gc + IF (config_flags%use_sh_qv .and. (flag_sh .eq. 1 .or. flag_qv .eq. 1)) THEN + CALL vert_interp ( grid%qv_gc , grid%pd_gc , moist(:,:,:,P_QV) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + ! If this is theta being interpolated, AND we have extra levels for temperature, ! convert those extra levels (trop and max wind) to potential temp. @@ -1778,6 +1821,8 @@ SUBROUTINE init_domain_rk ( grid & its , ite , jts , jte , kts , kte ) END IF + ! do not compute qv from RH if flag_sh or flag_qv = 1, or use_sh_qv = F + IF ( .not.config_flags%use_sh_qv ) THEN IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & @@ -1799,6 +1844,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF + END IF IF ( .NOT. config_flags%interp_theta ) THEN CALL t_to_theta ( grid%t_2 , grid%p , p00 , & @@ -3089,7 +3135,18 @@ SUBROUTINE init_domain_rk ( grid & ! Split NUDAPT Urban Parameters - IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN + distributed_aerodynamics_if: IF (config_flags%sf_urban_physics == 1 .AND. config_flags%slucm_distributed_drag) THEN + CALL nl_get_isurban ( grid%id , grid%isurban ) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF (grid%landusef(i, grid%isurban, j) > 0) THEN + grid%frc_urb2d(i, j) = MAX(0.1, MIN(0.9, 1 - grid%shdavg(i, j) / 100.)) + END IF + END DO + END DO + ELSE + + IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') THEN @@ -3111,7 +3168,7 @@ SUBROUTINE init_domain_rk ( grid & grid%HGT_URB2D(i,j) = grid%URB_PARAM(i,94,j) END DO END DO - ENDIF + ENDIF IF ( ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN DO j = jts , MIN(jde-1,jte) @@ -3145,6 +3202,8 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO + END IF distributed_aerodynamics_if + END IF ! Adjustments for the seaice field PRIOR to the grid%tslb computations. This is @@ -4042,6 +4101,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + IF ( .not.config_flags%use_sh_qv ) THEN IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & @@ -4063,6 +4123,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF + END IF ! Compute pressure similarly to how computed within model, with final Qv. @@ -7807,6 +7868,7 @@ SUBROUTINE compute_eta ( znw , auto_levels_opt , & do k = 2 ,kte WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m Thickness = ",F6.1," m")') k,phb(k)/g,(phb(k)-phb(k-1))/g end do +WRITE (*,FMT='("p_top = ",F7.0," Pa, dzbot = ",F6.1," m, dzstretch_s/u = ",2F6.2)') p_top,dzbot,dzstretch_s,dzstretch_u END IF @@ -7922,6 +7984,27 @@ SUBROUTINE monthly_min_max ( field_in , field_min , field_max , & END SUBROUTINE monthly_min_max +!--------------------------------------------------------------------- + + SUBROUTINE monthly_avg ( field_in , field_avg , & + 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,12,jms:jme) , INTENT(IN) :: field_in + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_avg + ! Local vars + INTEGER :: i , j + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + field_avg(i, j) = SUM(field_in(i, :, j)) / 12 + END DO + END DO + END SUBROUTINE monthly_avg + !--------------------------------------------------------------------- SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , & diff --git a/dyn_em/solve_em.F b/dyn_em/solve_em.F index 92d5b73fed..c5f47a50a6 100644 --- a/dyn_em/solve_em.F +++ b/dyn_em/solve_em.F @@ -3810,6 +3810,7 @@ END SUBROUTINE CMAQ_DRIVER & , SNOWNC=grid%snownc, SNOWNCV=grid%snowncv & & , GRAUPELNC=grid%graupelnc, GRAUPELNCV=grid%graupelncv & ! for milbrandt2mom & , HAILNC=grid%hailnc, HAILNCV=grid%hailncv & + & , HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & & , W=grid%w_2, Z=grid%z, HT=grid%ht & & , MP_RESTART_STATE=grid%mp_restart_state & & , TBPVS_STATE=grid%tbpvs_state & ! etampnew @@ -3859,11 +3860,11 @@ END SUBROUTINE CMAQ_DRIVER & , QNI3_CURR=scalar(ims,kms,jms,P_QNI3), F_QNI3=F_QNI3 & ! for Jensen ISHMAEL & , QVOLI3_CURR=scalar(ims,kms,jms,P_QVOLI3), F_QVOLI3=F_QVOLI3 & ! for Jensen ISHMAEL & , QAOLI3_CURR=scalar(ims,kms,jms,P_QAOLI3), F_QAOLI3=F_QAOLI3 & ! for Jensen ISHMAEL -! & , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR & ! for milbrandt3mom + & , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR & ! for milbrandt3mom & , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI & ! for 3-moment P3 ! & , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS & ! " -! & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! " -! & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! " + & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! " + & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! " & , QVOLG_CURR=scalar(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom & , QVOLH_CURR=scalar(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH & ! for nssl_2mom & , QDCN_CURR=scalar(ims,kms,jms,P_QDCN), F_QDCN=F_QDCN & ! for ntu3m @@ -4005,6 +4006,7 @@ END SUBROUTINE CMAQ_DRIVER jts = max(grid%j_start(ij),jds) jte = min(grid%j_end(ij),jde-1) + IF ( config_flags%mp_zero_out > 0 ) THEN CALL microphysics_zero_outb ( & moist , num_moist , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4012,6 +4014,7 @@ END SUBROUTINE CMAQ_DRIVER its, ite, jts, jte, & k_start , k_end ) + IF ( config_flags%mp_zero_out_all > 0 ) THEN CALL microphysics_zero_outb ( & scalar , num_scalar , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4020,7 +4023,7 @@ END SUBROUTINE CMAQ_DRIVER k_start , k_end ) CALL microphysics_zero_outb ( & - chem , num_chem , config_flags , & + chem , num_chem , config_flags , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & @@ -4031,6 +4034,8 @@ END SUBROUTINE CMAQ_DRIVER ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + ENDIF + ENDIF IF ( config_flags%periodic_x ) THEN its = max(grid%i_start(ij),ids) @@ -4042,6 +4047,7 @@ END SUBROUTINE CMAQ_DRIVER jts = max(grid%j_start(ij),jds+sz) jte = min(grid%j_end(ij),jde-1-sz) + IF ( config_flags%mp_zero_out > 0 ) THEN CALL microphysics_zero_outa ( & moist , num_moist , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4049,6 +4055,7 @@ END SUBROUTINE CMAQ_DRIVER its, ite, jts, jte, & k_start , k_end ) + IF ( config_flags%mp_zero_out_all > 0 ) THEN CALL microphysics_zero_outa ( & scalar , num_scalar , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4069,6 +4076,8 @@ END SUBROUTINE CMAQ_DRIVER ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + ENDIF + ENDIF CALL moist_physics_finish_em( grid%t_2, grid%t_1, t0, grid%muts, th_phy, & grid%h_diabatic, dtm, & diff --git a/dyn_em/start_em.F b/dyn_em/start_em.F index 07b2c751ee..1cfa6efdf7 100644 --- a/dyn_em/start_em.F +++ b/dyn_em/start_em.F @@ -1234,15 +1234,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%itimestep, grid%fdob, & t00, p00, a, & ! for obs_nudge base state grid%TYR, grid%TYRA, grid%TDLY, grid%TLAG, grid%NYEAR, grid%NDAY,grid%tmn_update, & - grid%achfx, grid%aclhf, grid%acgrdflx, & - config_flags%nssl_cccn, & - config_flags%nssl_alphah, config_flags%nssl_alphahl, & - config_flags%nssl_cnoh, config_flags%nssl_cnohl, & - config_flags%nssl_cnor, config_flags%nssl_cnos, & - config_flags%nssl_rho_qh, config_flags%nssl_rho_qhl, & - config_flags%nssl_rho_qs, & - config_flags%nssl_ipelec, & - config_flags%nssl_isaund & + grid%achfx, grid%aclhf, grid%acgrdflx & ,grid%RQCNCUTEN, grid%RQINCUTEN,grid%rliq & !mchen add for cammpmg ,grid%cldfra_dp,grid%cldfra_sh & ! ckay for subgrid cloud ,grid%te_temf,grid%cf3d_temf,grid%wm_temf & ! WA @@ -1759,8 +1751,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & IF ( f_qnn ) THEN IF ( config_flags%mp_physics == wdm5scheme .or. config_flags%mp_physics == wdm6scheme ) THEN ! NO OP - ELSE IF ( config_flags%mp_physics == nssl_2momccn ) THEN - grid%ccn_conc = config_flags%nssl_cccn/1.225 + ELSE IF ( config_flags%mp_physics == nssl_2mom ) THEN + IF ( config_flags%nssl_ccn_is_ccna == 0 ) THEN + grid%ccn_conc = config_flags%nssl_cccn/1.225 + ELSE + grid%ccn_conc = 0 + ENDIF ELSE ! NO OP END IF diff --git a/external/CMakeLists.txt b/external/CMakeLists.txt new file mode 100644 index 0000000000..7036a9debe --- /dev/null +++ b/external/CMakeLists.txt @@ -0,0 +1,85 @@ +# WRF CMake Build + +# The way ncep has written these makes this difficult if not impossible to do... +# # External projects, run them inline but make an alias to their target as if +# # we "built" them ourselves - useful to avoid ExternalProject_Add() + find_package() weirdness +# # Newer versions we might need to do that since g2 relies on bacio with find_package() +# add_subdirectory( bacio ) +# add_subdirectory( g2 ) + +# # bacio v2.6.0 +# add_library( bacio::bacio ALIAS bacio ) + +# # g2 v3.1.2 +# if ( ${USE_DOUBLE} ) +# add_library( g2::g2 ALIAS g2_d ) +# else() +# add_library( g2::g2 ALIAS g2_4 ) +# endif() + + +# Always build + +add_subdirectory( io_int ) +add_subdirectory( io_grib1 ) +add_subdirectory( io_grib_share ) +add_subdirectory( ioapi_share ) +add_subdirectory( fftpack/fftpack5 ) + +if ( AMT_OCN ) + # I have no clue how this gets used + message( STATUS "Adding [atm_ocn] to configuration" ) + add_subdirectory( atm_ocn ) +endif() + +if ( ADIOS2 ) + message( STATUS "Adding [io_adios2] to configuration" ) + add_subdirectory( io_adios2 ) +endif() + +if ( ESMF ) + message( STATUS "Adding [io_esmf] to configuration" ) + add_subdirectory( io_esmf ) +endif() + +#!TODO Is this always needed +add_subdirectory( esmf_time_f90 ) + +# netCDF +#!TODO I believe this is always required from configure:651 +add_subdirectory( io_netcdf ) +#!TODO We should collapse all these files into #ifdefs even if they are compiled +# multiple times with different defs for the same configuration +if ( ${netCDF_PARALLEL} AND ${USE_MPI} ) + message( STATUS "Adding [io_netcdfpar] to configuration" ) + add_subdirectory( io_netcdfpar ) +endif() + +if ( ${pnetCDF_FOUND} ) + message( STATUS "Adding [io_pnetcdf] to configuration" ) + add_subdirectory( io_pnetcdf ) +endif() + +if ( ${PIO_FOUND} ) + message( STATUS "Adding [io_pio] to configuration" ) + add_subdirectory( io_pio ) +endif() + +# https://cmake.org/cmake/help/latest/module/FindHDF5.html +# I don't think this is the correct variable to control this IO capability... +if ( ${HDF5_IS_PARALLEL} ) + message( STATUS "Adding [io_phdf5] to configuration" ) + add_subdirectory( io_phdf5 ) +endif() + + +if ( ${Jasper_FOUND} ) + message( STATUS "Adding [io_grib2] to configuration" ) + add_subdirectory( io_grib2 ) +endif() + +if ( ${USE_RSL_LITE} ) + add_subdirectory( RSL_LITE ) +endif() + + diff --git a/external/RSL_LITE/CMakeLists.txt b/external/RSL_LITE/CMakeLists.txt new file mode 100644 index 0000000000..5f38783343 --- /dev/null +++ b/external/RSL_LITE/CMakeLists.txt @@ -0,0 +1,51 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + c_code.c + buf_for_proc.c + rsl_malloc.c + rsl_bcast.c + task_for_point.c + period.c + swap.c + cycle.c + f_pack.F90 + f_xpose.F90 + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/RSL_LITE/buf_for_proc.c b/external/RSL_LITE/buf_for_proc.c index 5d50cbf14a..e31703091a 100755 --- a/external/RSL_LITE/buf_for_proc.c +++ b/external/RSL_LITE/buf_for_proc.c @@ -148,6 +148,7 @@ fprintf(stderr,"buffer_for_proc %s %d : was %d, increasing to %d\n", return(ret) ; } +int show_tot_size() { int P ; @@ -164,9 +165,7 @@ show_tot_size() } int -buffer_size_for_proc( P, code ) - int P ; - int code ; +buffer_size_for_proc( int P, int code ) { return( buftab[code][P].size ) ; } diff --git a/external/RSL_LITE/c_code.c b/external/RSL_LITE/c_code.c index 27549bdf9c..8db9aba3ba 100755 --- a/external/RSL_LITE/c_code.c +++ b/external/RSL_LITE/c_code.c @@ -14,6 +14,8 @@ #ifdef _WIN32 #include +#else +#include #endif #ifdef NCEP_DEBUG_MULTIDIR // # include @@ -243,6 +245,7 @@ gethostid () } #endif +int RSL_LITE_GET_HOSTNAME ( char * hn, int * size, int *n, int *hostid ) { char temp[512] ; @@ -256,6 +259,7 @@ RSL_LITE_GET_HOSTNAME ( char * hn, int * size, int *n, int *hostid ) return(0) ; } +int BYTE_BCAST ( char * buf, int * size, int * Fcomm ) { #ifndef STUBMPI @@ -275,6 +279,7 @@ BYTE_BCAST ( char * buf, int * size, int * Fcomm ) #endif } +int BYTE_BCAST_FROM_ROOT ( char * buf, int * size, int *root , int * Fcomm ) { #ifndef STUBMPI @@ -297,6 +302,7 @@ BYTE_BCAST_FROM_ROOT ( char * buf, int * size, int *root , int * Fcomm ) static int yp_curs, ym_curs, xp_curs, xm_curs ; static int yp_curs_recv, ym_curs_recv, xp_curs_recv, xm_curs_recv ; +int RSL_LITE_INIT_EXCH ( int * Fcomm0, int * shw0, int * xy0 , @@ -395,6 +401,7 @@ RSL_LITE_INIT_EXCH ( xp_curs_recv = nbytes_x_recv ; xm_curs_recv = nbytes_x_recv ; } +int RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 , int * sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 , int * recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 , @@ -690,6 +697,7 @@ RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 , } #if ( WRFPLUS == 1 ) +int RSL_LITE_PACK_AD ( int * Fcomm0, char * buf , int * shw0 , int * sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 , int * recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 , @@ -989,6 +997,7 @@ static MPI_Request yp_recv, ym_recv, yp_send, ym_send ; static MPI_Request xp_recv, xm_recv, xp_send, xm_send ; #endif +int RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 , int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p ) { @@ -1026,6 +1035,7 @@ RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 #endif } +int RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 , int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p ) { @@ -1065,6 +1075,7 @@ RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 #if !defined( MS_SUA) && !defined(_WIN32) #include +int RSL_INTERNAL_MILLICLOCK () { struct timeval tb ; @@ -1078,6 +1089,7 @@ RSL_INTERNAL_MILLICLOCK () msecs = 1000 * isec + usec / 1000 ; return(msecs) ; } +int RSL_INTERNAL_MICROCLOCK () { struct timeval tb ; diff --git a/external/RSL_LITE/cycle.c b/external/RSL_LITE/cycle.c index e9b2738e2d..0acfd9e3a8 100644 --- a/external/RSL_LITE/cycle.c +++ b/external/RSL_LITE/cycle.c @@ -32,7 +32,7 @@ static int *nbytes_dst = NULL ; static MPI_Request *x_recv = NULL , *x_send = NULL ; #endif -RSL_LITE_INIT_CYCLE ( int * Fcomm , +void RSL_LITE_INIT_CYCLE ( int * Fcomm , int * xy0 , int * inout0 , int * n3dR0, int *n2dR0, int * typesizeR0 , int * n3dI0, int *n2dI0, int * typesizeI0 , @@ -142,7 +142,7 @@ RSL_LITE_INIT_CYCLE ( int * Fcomm , #endif } -RSL_LITE_PACK_CYCLE ( int * Fcomm, char * buf , int * inout0 , int * typesize0 , int * xy0 , int * pu0 , char * memord , int * xstag0 , +void RSL_LITE_PACK_CYCLE ( int * Fcomm, char * buf , int * inout0 , int * typesize0 , int * xy0 , int * pu0 , char * memord , int * xstag0 , int *me0, int * np0 , int * np_x0 , int * np_y0 , int * min_subdomain, int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 , @@ -343,7 +343,7 @@ RSL_LITE_PACK_CYCLE ( int * Fcomm, char * buf , int * inout0 , int * typesize0 , #endif } -RSL_LITE_CYCLE ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) +void RSL_LITE_CYCLE ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) { int me, np, np_x, np_y ; int yp, ym, xp, xm, nb ; diff --git a/external/RSL_LITE/gen_comms.c b/external/RSL_LITE/gen_comms.c index 2a6b2ef5bd..d62c5cb5af 100644 --- a/external/RSL_LITE/gen_comms.c +++ b/external/RSL_LITE/gen_comms.c @@ -1218,6 +1218,7 @@ fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxste } #endif +int #if ( WRFPLUS == 1 ) gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, int nta /* 0=NLM,1=TLM,2=ADM*/, char * packname, char * commname, int always_interp_mp ) #else @@ -1454,6 +1455,7 @@ fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%s } } +int gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname ) { node_t * q ; diff --git a/external/RSL_LITE/period.c b/external/RSL_LITE/period.c index 8e288b6ccf..b0401d03c5 100755 --- a/external/RSL_LITE/period.c +++ b/external/RSL_LITE/period.c @@ -14,7 +14,7 @@ static int yp_curs, ym_curs, xp_curs, xm_curs ; -RSL_LITE_INIT_PERIOD ( +void RSL_LITE_INIT_PERIOD ( int * Fcomm0, int * shw0, int * n3dR0, int *n2dR0, int * typesizeR0 , @@ -93,7 +93,7 @@ RSL_LITE_INIT_PERIOD ( } -RSL_LITE_PACK_PERIOD ( int* Fcomm0, char * buf , int * shw0 , int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * stag0 , +void RSL_LITE_PACK_PERIOD ( int* Fcomm0, char * buf , int * shw0 , int * typesize0 , int * xy0 , int * pu0 , int * imemord , int * stag0 , int *me0, int * np0 , int * np_x0 , int * np_y0 , int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 , int * ims0 , int * ime0 , int * jms0 , int * jme0 , int * kms0 , int * kme0 , @@ -368,7 +368,7 @@ static MPI_Request yp_recv, ym_recv, yp_send, ym_send ; static MPI_Request xp_recv, xm_recv, xp_send, xm_send ; #endif -RSL_LITE_EXCH_PERIOD_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) +void RSL_LITE_EXCH_PERIOD_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) { #ifndef STUBMPI int me, np, np_x, np_y ; @@ -414,7 +414,7 @@ fprintf(stderr,"RSL_LITE_EXCH_PERIOD_X disabled\n") ; #endif } -RSL_LITE_EXCH_PERIOD_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) +void RSL_LITE_EXCH_PERIOD_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) { #ifndef STUBMPI int me, np, np_x, np_y ; diff --git a/external/RSL_LITE/rsl_bcast.c b/external/RSL_LITE/rsl_bcast.c index d3e7d10691..28c6725d7e 100755 --- a/external/RSL_LITE/rsl_bcast.c +++ b/external/RSL_LITE/rsl_bcast.c @@ -74,13 +74,13 @@ typedef struct bcast_point_desc { } bcast_point_desc_t ; -static destroy_par_info ( p ) +static int destroy_par_info ( p ) char * p ; { if ( p != NULL ) RSL_FREE( p ) ; } -static destroy_list( list, dfcn ) +static int destroy_list( list, dfcn ) rsl_list_t ** list ; /* pointer to pointer to list */ int (*dfcn)() ; /* pointer to function for destroying the data field of the list */ @@ -161,7 +161,7 @@ static int s_putmsg = 0 ; // It needs the minor number of tasks on the nest's MPI mesh (just pass that in) // Otherwise it doesn't need a communicator -RSL_LITE_NESTING_RESET ( +void RSL_LITE_NESTING_RESET ( ) { int j ; @@ -452,7 +452,6 @@ void RSL_LITE_TO_PARENT_INFO ( msize_p, return ; } - /********************************************/ /*@ @@ -460,28 +459,9 @@ void RSL_LITE_TO_PARENT_INFO ( msize_p, @*/ -/* parent->nest */ -RSL_LITE_TO_CHILD_MSG ( nbuf_p, buf ) - int_p - nbuf_p ; /* (I) Number of bytes to be packed. */ - char * - buf ; /* (I) Buffer containing the data to be packed. */ -{ - rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ; -} - -/* nest->parent */ -RSL_LITE_TO_PARENT_MSG ( nbuf_p, buf ) - int_p - nbuf_p ; /* (I) Number of bytes to be packed. */ - char * - buf ; /* (I) Buffer containing the data to be packed. */ -{ - rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ; -} /* common code */ -rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) +void rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) int_p nbuf_p ; /* (I) Number of bytes to be packed. */ char * @@ -521,45 +501,39 @@ rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) } -/********************************************/ - -// PARALLELNESTING NOTES -// what communicator should be passed and what are mytask and ntasks? -// I think it should be the mom_and_me communicator and the mytask and ntasks from -// that communicator -// -// nest if it's parent->nest and the parent if it's nest->parent (we'll see) /* parent->nest */ -RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ) - int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ; /* offset is the id of the first task in the nest set */ +void RSL_LITE_TO_CHILD_MSG ( nbuf_p, buf ) + int_p + nbuf_p ; /* (I) Number of bytes to be packed. */ + char * + buf ; /* (I) Buffer containing the data to be packed. */ { -#ifndef STUBMPI - MPI_Comm comm ; - - comm = MPI_Comm_f2c( *Fcomm ) ; -#else - int comm ; -#endif - rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 0 ) ; + rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ; } /* nest->parent */ -RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ) - int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ; /* offset is the id of the first task in the nest set */ +void RSL_LITE_TO_PARENT_MSG ( nbuf_p, buf ) + int_p + nbuf_p ; /* (I) Number of bytes to be packed. */ + char * + buf ; /* (I) Buffer containing the data to be packed. */ { -#ifndef STUBMPI - MPI_Comm comm ; - - comm = MPI_Comm_f2c( *Fcomm ) ; -#else - int comm ; -#endif - rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 1 ) ; + rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) ; } + +/********************************************/ + +// PARALLELNESTING NOTES +// what communicator should be passed and what are mytask and ntasks? +// I think it should be the mom_and_me communicator and the mytask and ntasks from +// that communicator +// +// nest if it's parent->nest and the parent if it's nest->parent (we'll see) + /* common code */ -rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, dir ) +void rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, dir ) int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p ; int dir ; /* 0 = parent to nest, otherwist nest to parent */ #ifndef STUBMPI @@ -651,30 +625,38 @@ rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, } -/********************************************/ - /* parent->nest */ -RSL_LITE_FROM_PARENT_INFO ( ig_p, jg_p, retval_p ) - int_p - ig_p /* (O) Global index in M dimension of nest. */ - ,jg_p /* (O) Global index in N dimension of nest. */ - ,retval_p ; /* (O) Return value; =1 valid point, =0 done. */ +void RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ) + int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ; /* offset is the id of the first task in the nest set */ { - rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ; +#ifndef STUBMPI + MPI_Comm comm ; + + comm = MPI_Comm_f2c( *Fcomm ) ; +#else + int comm ; +#endif + rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 0 ) ; } /* nest->parent */ -RSL_LITE_FROM_CHILD_INFO ( ig_p, jg_p, retval_p ) - int_p - ig_p /* (O) Global index in M dimension of nest. */ - ,jg_p /* (O) Global index in N dimension of nest. */ - ,retval_p ; /* (O) Return value; =1 valid point, =0 done. */ +void RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ) + int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ; /* offset is the id of the first task in the nest set */ { - rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ; +#ifndef STUBMPI + MPI_Comm comm ; + + comm = MPI_Comm_f2c( *Fcomm ) ; +#else + int comm ; +#endif + rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 1 ) ; } +/********************************************/ + /* common code */ -rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) +void rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) int_p ig_p /* (O) Global index in M dimension of nest. */ ,jg_p /* (O) Global index in N dimension of nest. */ @@ -696,30 +678,31 @@ rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) } -/********************************************/ - /* parent->nest */ -RSL_LITE_FROM_PARENT_MSG ( len_p, buf ) +void RSL_LITE_FROM_PARENT_INFO ( ig_p, jg_p, retval_p ) int_p - len_p ; /* (I) Number of bytes to unpack. */ - int * - buf ; /* (O) Destination buffer. */ + ig_p /* (O) Global index in M dimension of nest. */ + ,jg_p /* (O) Global index in N dimension of nest. */ + ,retval_p ; /* (O) Return value; =1 valid point, =0 done. */ { - rsl_lite_from_peerpoint_msg ( len_p, buf ) ; + rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ; } /* nest->parent */ -RSL_LITE_FROM_CHILD_MSG ( len_p, buf ) +void RSL_LITE_FROM_CHILD_INFO ( ig_p, jg_p, retval_p ) int_p - len_p ; /* (I) Number of bytes to unpack. */ - int * - buf ; /* (O) Destination buffer. */ + ig_p /* (O) Global index in M dimension of nest. */ + ,jg_p /* (O) Global index in N dimension of nest. */ + ,retval_p ; /* (O) Return value; =1 valid point, =0 done. */ { - rsl_lite_from_peerpoint_msg ( len_p, buf ) ; + rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) ; } + +/********************************************/ + /* common code */ -rsl_lite_from_peerpoint_msg ( len_p, buf ) +void rsl_lite_from_peerpoint_msg ( len_p, buf ) int_p len_p ; /* (I) Number of bytes to unpack. */ int * @@ -744,5 +727,26 @@ rsl_lite_from_peerpoint_msg ( len_p, buf ) Rpointcurs += *len_p ; } +/* parent->nest */ +void RSL_LITE_FROM_PARENT_MSG ( len_p, buf ) + int_p + len_p ; /* (I) Number of bytes to unpack. */ + int * + buf ; /* (O) Destination buffer. */ +{ + rsl_lite_from_peerpoint_msg ( len_p, buf ) ; +} + +/* nest->parent */ +void RSL_LITE_FROM_CHILD_MSG ( len_p, buf ) + int_p + len_p ; /* (I) Number of bytes to unpack. */ + int * + buf ; /* (O) Destination buffer. */ +{ + rsl_lite_from_peerpoint_msg ( len_p, buf ) ; +} + + /********************************************/ diff --git a/external/RSL_LITE/rsl_lite.h b/external/RSL_LITE/rsl_lite.h index da430be967..f3e291350f 100644 --- a/external/RSL_LITE/rsl_lite.h +++ b/external/RSL_LITE/rsl_lite.h @@ -164,6 +164,8 @@ #define RSL_FREE(P) rsl_free(&(P)) char * buffer_for_proc ( int P, int size, int code ) ; +int buffer_size_for_proc( int P, int code ); + void * rsl_malloc( char * f, int l, int s ) ; void rsl_free( char ** p ) ; typedef int * int_p ; @@ -194,3 +196,18 @@ typedef struct rsl_list { #endif } rsl_list_t ; + +void F_PACK_LINT (long *inbuf, long *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +void F_PACK_INT (int *inbuf, int *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +void F_UNPACK_LINT (long *inbuf, long *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +void F_UNPACK_INT (int *inbuf, int *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); + +#if ( WRFPLUS == 1 ) +void F_PACK_LINT_AD (long *inbuf, long *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +void F_PACK_INT_AD (int *inbuf, int *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +void F_UNPACK_LINT_AD (long *inbuf, long *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +void F_UNPACK_INT_AD (int *inbuf, int *outbuf, int* memorder, int* js, int* je, int* ks, int* ke, int* is, int* ie, int* jms, int* jme, int* kms, int* kme, int* ims, int* ime, int* curs); +#endif + +int TASK_FOR_POINT ( int* i_p , int* j_p , int* ids_p, int* ide_p , int* jds_p, int* jde_p , int* npx_p , int* npy_p , int* Px_p, int* Py_p , int* minx_p, int* miny_p, int* ierr_p ); +void TASK_FOR_POINT_MESSAGE(); diff --git a/external/RSL_LITE/rsl_malloc.c b/external/RSL_LITE/rsl_malloc.c index 4a4cdd1001..689eed3401 100755 --- a/external/RSL_LITE/rsl_malloc.c +++ b/external/RSL_LITE/rsl_malloc.c @@ -85,7 +85,8 @@ # include "mpi.h" #endif #include "rsl_lite.h" - +#include +#include /* extern int EF_ALIGNMENT; extern int EF_PROTECT_BELOW; diff --git a/external/RSL_LITE/swap.c b/external/RSL_LITE/swap.c index 28ac424d04..5c32380da4 100644 --- a/external/RSL_LITE/swap.c +++ b/external/RSL_LITE/swap.c @@ -2,6 +2,7 @@ # include #endif #include +#include #define STANDARD_ERROR 2 @@ -27,7 +28,7 @@ static int *nbytes = NULL ; static MPI_Request *x_recv = NULL , *x_send = NULL ; #endif -RSL_LITE_INIT_SWAP ( +void RSL_LITE_INIT_SWAP ( int * Fcomm , int * xy0 , int * n3dR0, int *n2dR0, int * typesizeR0 , @@ -119,7 +120,7 @@ RSL_LITE_INIT_SWAP ( #endif } -RSL_LITE_PACK_SWAP ( int * Fcomm , char * buf , int * odd0 , int * typesize0 , int * xy0 , int * pu0 , char * memord , int * xstag0 , +void RSL_LITE_PACK_SWAP ( int * Fcomm , char * buf , int * odd0 , int * typesize0 , int * xy0 , int * pu0 , char * memord , int * xstag0 , int *me0, int * np0 , int * np_x0 , int * np_y0 , int * min_subdomain , int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 , @@ -304,7 +305,7 @@ RSL_LITE_PACK_SWAP ( int * Fcomm , char * buf , int * odd0 , int * typesize0 , i #endif } -RSL_LITE_SWAP ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) +void RSL_LITE_SWAP ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ) { #ifndef STUBMPI int me, np, np_x, np_y ; diff --git a/external/RSL_LITE/task_for_point.c b/external/RSL_LITE/task_for_point.c index b33a03c452..6da4cd5aa5 100644 --- a/external/RSL_LITE/task_for_point.c +++ b/external/RSL_LITE/task_for_point.c @@ -20,8 +20,7 @@ static char tfpmess[1024] ; -TASK_FOR_POINT ( i_p , j_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p , Px_p, Py_p , minx_p, miny_p, ierr_p ) - int_p i_p , j_p , Px_p , Py_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p, minx_p, miny_p, ierr_p ; +int TASK_FOR_POINT ( int* i_p , int* j_p , int* ids_p, int* ide_p , int* jds_p, int* jde_p , int* npx_p , int* npy_p , int* Px_p, int* Py_p , int* minx_p, int* miny_p, int* ierr_p ) { int i , j , ids, ide, jds, jde, npx, npy, minx, miny ; /* inputs */ int Px, Py ; /* output */ @@ -124,7 +123,7 @@ TASK_FOR_POINT ( i_p , j_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p , Px_p, *Py_p = Py ; } -TASK_FOR_POINT_MESSAGE() +void TASK_FOR_POINT_MESSAGE() { fprintf(stderr,"%s\n",tfpmess) ; } diff --git a/external/atm_ocn/CMakeLists.txt b/external/atm_ocn/CMakeLists.txt new file mode 100644 index 0000000000..2fe79f79d3 --- /dev/null +++ b/external/atm_ocn/CMakeLists.txt @@ -0,0 +1,47 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + atm_comm.F + atm_tiles.F + cmpcomm.F + mpi_more.F + module_PATCH_QUILT.F + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + Fortran_FORMAT FIXED + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/atm_ocn/cmpcomm.F b/external/atm_ocn/cmpcomm.F index a78e285337..89cd554e1c 100644 --- a/external/atm_ocn/cmpcomm.F +++ b/external/atm_ocn/cmpcomm.F @@ -1,4 +1,4 @@ -#if defined( DM_PARALLEL ) +#ifdef DM_PARALLEL MODULE CMP_COMM implicit none diff --git a/external/esmf_time_f90/CMakeLists.txt b/external/esmf_time_f90/CMakeLists.txt new file mode 100644 index 0000000000..3bba5fdd69 --- /dev/null +++ b/external/esmf_time_f90/CMakeLists.txt @@ -0,0 +1,62 @@ +# WRF CMake Build +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) +# Test1_ESMF +# Test1_WRFU +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + ESMF_Alarm.F90 + ESMF_BaseTime.F90 + ESMF_Clock.F90 + ESMF_Time.F90 + Meat.F90 + ESMF_Base.F90 + ESMF_Calendar.F90 + ESMF_Fraction.F90 + ESMF_TimeInterval.F90 + ESMF_Stubs.F90 + ESMF_Mod.F90 + module_symbols_util.F90 + module_utility.F90 + ESMF_AlarmClock.F90 + ) + +# target_compile_options( +# ${FOLDER_COMPILE_TARGET} +# PRIVATE +# # Specific flags for this target +# ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_LIST_DIR} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/fftpack/fftpack5/CMakeLists.txt b/external/fftpack/fftpack5/CMakeLists.txt new file mode 100644 index 0000000000..1ae8c648de --- /dev/null +++ b/external/fftpack/fftpack5/CMakeLists.txt @@ -0,0 +1,53 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + c1f2kb.F cfft1b.F cmf3kf.F cosqb1.F costmi.F dcosq1f.F dfftb1.F mradb2.F mrfti1.F r1fgkf.F rfft2i.F sinqmi.F z1f2kf.F zfft1f.F zmf4kb.F + c1f2kf.F cfft1f.F cmf4kb.F cosqf1.F d1f2kb.F dcosq1i.F dfftf1.F mradb3.F msntb1.F r4_factor.F rfftb1.F sint1b.F z1f3kb.F zfft1i.F zmf4kf.F + c1f3kb.F cfft1i.F cmf4kf.F cosqmb.F d1f2kf.F dcosqb1.F dffti1.F mradb4.F msntf1.F r4_mcfti1.F rfftf1.F sint1f.F z1f3kf.F zfft2b.F zmf5kb.F + c1f3kf.F cfft2b.F cmf5kb.F cosqmf.F d1f3kb.F dcosqf1.F dsint1b.F mradb5.F r1f2kb.F r4_tables.F rffti1.F sint1i.F z1f4kb.F zfft2f.F zmf5kf.F + c1f4kb.F cfft2f.F cmf5kf.F cosqmi.F d1f3kf.F dcost1b.F dsint1f.F mradbg.F r1f2kf.F r8_factor.F rfftmb.F sintb1.F z1f4kf.F zfft2i.F zmfgkb.F + c1f4kf.F cfft2i.F cmfgkb.F cost1b.F d1f4kb.F dcost1f.F dsint1i.F mradf2.F r1f3kb.F r8_mcfti1.F rfftmf.F sintf1.F z1f5kb.F zfftmb.F zmfgkf.F + c1f5kb.F cfftmb.F cmfgkf.F cost1f.F d1f4kf.F dcost1i.F dsintb1.F mradf3.F r1f3kf.F r8_tables.F rfftmi.F sintmb.F z1f5kf.F zfftmf.F zmfm1b.F + c1f5kf.F cfftmf.F cmfm1b.F cost1i.F d1f5kb.F dcostb1.F dsintf1.F mradf4.F r1f4kb.F rfft1b.F sinq1b.F sintmf.F z1fgkb.F zfftmi.F zmfm1f.F + c1fgkb.F cfftmi.F cmfm1f.F costb1.F d1f5kf.F dcostf1.F mcsqb1.F mradf5.F r1f4kf.F rfft1f.F sinq1f.F sintmi.F z1fgkf.F zmf2kb.F + c1fgkf.F cmf2kb.F cosq1b.F costf1.F d1fgkb.F dfft1b.F mcsqf1.F mradfg.F r1f5kb.F rfft1i.F sinq1i.F xercon.F z1fm1b.F zmf2kf.F + c1fm1b.F cmf2kf.F cosq1f.F costmb.F d1fgkf.F dfft1f.F mcstb1.F mrftb1.F r1f5kf.F rfft2b.F sinqmb.F xerfft.F z1fm1f.F zmf3kb.F + c1fm1f.F cmf3kb.F cosq1i.F costmf.F dcosq1b.F dfft1i.F mcstf1.F mrftf1.F r1fgkb.F rfft2f.F sinqmf.F z1f2kb.F zfft1b.F zmf3kf.F + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + Fortran_FORMAT FREE + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_adios2/CMakeLists.txt b/external/io_adios2/CMakeLists.txt new file mode 100644 index 0000000000..dde531a716 --- /dev/null +++ b/external/io_adios2/CMakeLists.txt @@ -0,0 +1,74 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +# Do this first to simplify steps later +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_SOURCE_DIR}/../ioapi_share + ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + ) + + +# First preprocess +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +get_target_property ( FOLDER_COMPILE_TARGET_INCLUDES ${FOLDER_COMPILE_TARGET} INCLUDE_DIRECTORIES ) +wrf_c_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + INCLUDES ${FOLDER_COMPILE_TARGET_INCLUDES} + DEFINITIONS ${DIR_DEFS} + SOURCES wrf_io.F90 + ) + +# Now M4 preprocess +wrf_m4_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + PREFIX "m4_preproc_" + EXTENSION ".f90" + SOURCES ${CMAKE_CURRENT_BINARY_DIR}/preproc/wrf_io.f90 + DEPENDENCIES ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + TARGET_SCOPE ${FOLDER_COMPILE_TARGET} + FLAGS ${M4_FLAGS} + ) + +add_dependencies( ${FOLDER_COMPILE_TARGET} ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + ${CMAKE_CURRENT_BINARY_DIR}/preproc/m4_preproc_wrf_io.f90 + field_routines.F90 + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_adios2/wrf_io.F90 b/external/io_adios2/wrf_io.F90 index 3d5fdd6844..d53ad88481 100644 --- a/external/io_adios2/wrf_io.F90 +++ b/external/io_adios2/wrf_io.F90 @@ -702,9 +702,9 @@ subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) - - !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) - ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) +! Cannot use following define due to gfortran cpp traditional mode concatenation limitations +!#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) +! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) case ('xzy') #undef DFIELD #define DFIELD XField(1:di,XDEX(i,k,j)) diff --git a/external/io_esmf/CMakeLists.txt b/external/io_esmf/CMakeLists.txt new file mode 100644 index 0000000000..522e20bc00 --- /dev/null +++ b/external/io_esmf/CMakeLists.txt @@ -0,0 +1,50 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + module_symbols_util.F90 + module_esmf_extensions.F90 + module_utility.F90 + io_esmf.F90 + ext_esmf_open_for_read.F90 + ext_esmf_open_for_write.F90 + ext_esmf_read_field.F90 + ext_esmf_write_field.F90 + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib1/CMakeLists.txt b/external/io_grib1/CMakeLists.txt new file mode 100644 index 0000000000..c21a07be84 --- /dev/null +++ b/external/io_grib1/CMakeLists.txt @@ -0,0 +1,55 @@ +# WRF CMake Build + +add_subdirectory( MEL_grib1 ) +add_subdirectory( grib1_util ) +add_subdirectory( WGRIB ) + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + grib1_routines.c + gribmap.c + io_grib1.F + trim.c + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + Fortran_FORMAT FREE + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_SOURCE_DIR}/../ioapi_share + ${CMAKE_CURRENT_SOURCE_DIR}/../io_grib_share + ${CMAKE_CURRENT_SOURCE_DIR}/grib1_util + ${CMAKE_CURRENT_SOURCE_DIR}/MEL_grib1 + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib1/MEL_grib1/CMakeLists.txt b/external/io_grib1/MEL_grib1/CMakeLists.txt new file mode 100644 index 0000000000..b275211c69 --- /dev/null +++ b/external/io_grib1/MEL_grib1/CMakeLists.txt @@ -0,0 +1,71 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + FTP_getfile.c + apply_bitmap.c + display_gribhdr.c + gbyte.c + grib_dec.c + grib_enc.c + grib_seek.c + gribgetbds.c + gribgetbms.c + gribgetgds.c + gribgetpds.c + gribhdr2file.c + gribputbds.c + gribputgds.c + gribputpds.c + hdr_print.c + init_dec_struct.c + init_enc_struct.c + init_gribhdr.c + init_struct.c + ld_dec_lookup.c + ld_enc_input.c + ld_enc_lookup.c + ld_grib_origctrs.c + make_default_grbfn.c + make_grib_log.c + map_lvl.c + map_parm.c + pack_spatial.c + prt_inp_struct.c + upd_child_errmsg.c + prt_badmsg.c + swap.c + grib_uthin.c + set_bytes.c + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_SOURCE_DIR}/../../ioapi_share + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib1/MEL_grib1/FTP_getfile.c b/external/io_grib1/MEL_grib1/FTP_getfile.c index 8fd4d5f675..08b0820955 100644 --- a/external/io_grib1/MEL_grib1/FTP_getfile.c +++ b/external/io_grib1/MEL_grib1/FTP_getfile.c @@ -1,5 +1,12 @@ #include #include +#include + +#if defined(_WIN32) +#include +#else +#include +#endif #include "dprints.h" /* Debug printing & function prototypes*/ #include "gribfuncs.h" /* function prototypes */ diff --git a/external/io_grib1/MEL_grib1/gribfuncs.h b/external/io_grib1/MEL_grib1/gribfuncs.h index a05f0fde97..42207e457d 100644 --- a/external/io_grib1/MEL_grib1/gribfuncs.h +++ b/external/io_grib1/MEL_grib1/gribfuncs.h @@ -29,12 +29,16 @@ int grib_dec (char *,PDS_INPUT *,grid_desc_sec *,BDS_HEAD_INPUT *, int grib_enc (DATA_INPUT,USER_INPUT,GEOM_IN,float *,GRIB_HDR *,char *); float grib_ibm_local(unsigned long ibm_float); int grib_seek (char *,long *,int,GRIB_HDR *,char *); +int grib_fseek (FILE *, long *, int, GRIB_HDR *, char *); + int gribgetbds (char *,short,BMS_INPUT *,grid_desc_sec *,float **, BDS_HEAD_INPUT *, char *); int gribgetbms (char *,BMS_INPUT *,int,unsigned long,char *); int gribgetgds (char *,grid_desc_sec *,char *); int gribgetpds (char *,PDS_INPUT *,char *); int gribhdr2file (GRIB_HDR *,FILE *,char *); +int gribhdr2filed (GRIB_HDR *, int , char *); + int gribputbds (USER_INPUT,long,short,float *,BDS_HEAD_INPUT *, GRIB_HDR **,char *); int gribputgds (GEOM_IN,GDS_HEAD_INPUT *,void **,GRIB_HDR **,char *); @@ -44,10 +48,12 @@ void init_dec_struct (PDS_INPUT *,grid_desc_sec *,BMS_INPUT *,BDS_HEAD_INPUT *); void init_enc_struct (DATA_INPUT *,GEOM_IN *,USER_INPUT *); int init_gribhdr (GRIB_HDR **,char *); void init_struct (void *, int); -int inp2Grib_Lambert (void **,LAMBERT *,long *,char *); +int inp2grib_Lambert (void **,LAMBERT *,long *,char *); int inp2grib_Latlon (void **,LATLON *,long *,char *); int inp2grib_PDS (PDS_INPUT *,PDS_GRIB **,char *); int inp2grib_PolarSt (void **,POLAR *,long *,char *); +int create_inpMercator (GEOM_IN , void **, char *); +int inp2grib_Mercator (void **, MERCATOR *,long *, char *); int ld_dec_lookup (char *,char *); int ld_enc_config (char *,USER_INPUT *,char *); int ld_enc_ffinfo (char *, DATA_INPUT *,char *); @@ -65,6 +71,11 @@ void prt_inp_struct (PDS_INPUT *,grid_desc_sec *, BMS_INPUT *, struct BDS_HEAD_INPUT *,float **); void upd_child_errmsg (char *,char *); void w3ft33_(float *ain,float **out, int *nsflag); + +void set_bytes(long in, int numbytes, char *out); +void set_bytes_u(unsigned long in, int numbytes, unsigned char *out); +int grib_unthin(float *in,float *out,int *rowsizes, int ysize, int *xsize); + #else #define PROTOTYPE_NEEDED 0 diff --git a/external/io_grib1/MEL_grib1/gribgetbds.c b/external/io_grib1/MEL_grib1/gribgetbds.c index abc3e5264a..f6958a9282 100644 --- a/external/io_grib1/MEL_grib1/gribgetbds.c +++ b/external/io_grib1/MEL_grib1/gribgetbds.c @@ -1,5 +1,6 @@ #include #include +#include #include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/MEL_grib1/gribhdr2file.c b/external/io_grib1/MEL_grib1/gribhdr2file.c index 41c248bce9..649c46dc0e 100644 --- a/external/io_grib1/MEL_grib1/gribhdr2file.c +++ b/external/io_grib1/MEL_grib1/gribhdr2file.c @@ -2,6 +2,13 @@ #include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ + +#if defined(_WIN32) +#include +#else +#include +#endif + /* * ************************************************************************ diff --git a/external/io_grib1/MEL_grib1/init_enc_struct.c b/external/io_grib1/MEL_grib1/init_enc_struct.c index 9e5ce13fd6..dd2a79cdea 100644 --- a/external/io_grib1/MEL_grib1/init_enc_struct.c +++ b/external/io_grib1/MEL_grib1/init_enc_struct.c @@ -5,6 +5,7 @@ */ #include #include +#include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ /* diff --git a/external/io_grib1/MEL_grib1/init_gribhdr.c b/external/io_grib1/MEL_grib1/init_gribhdr.c index ea0be9820f..b1580936e5 100644 --- a/external/io_grib1/MEL_grib1/init_gribhdr.c +++ b/external/io_grib1/MEL_grib1/init_gribhdr.c @@ -3,6 +3,7 @@ */ #include #include +#include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ /* diff --git a/external/io_grib1/MEL_grib1/init_struct.c b/external/io_grib1/MEL_grib1/init_struct.c index bf81ed176c..5bc0e452ca 100644 --- a/external/io_grib1/MEL_grib1/init_struct.c +++ b/external/io_grib1/MEL_grib1/init_struct.c @@ -6,6 +6,7 @@ */ #include #include +#include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/MEL_grib1/ld_enc_input.c b/external/io_grib1/MEL_grib1/ld_enc_input.c index b8a911925f..a4979aeb0c 100644 --- a/external/io_grib1/MEL_grib1/ld_enc_input.c +++ b/external/io_grib1/MEL_grib1/ld_enc_input.c @@ -10,6 +10,7 @@ Original version from previous Encoder Library; #include #include #include +#include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/MEL_grib1/ld_enc_lookup.c b/external/io_grib1/MEL_grib1/ld_enc_lookup.c index 8605aac126..3330d478a2 100644 --- a/external/io_grib1/MEL_grib1/ld_enc_lookup.c +++ b/external/io_grib1/MEL_grib1/ld_enc_lookup.c @@ -6,7 +6,7 @@ #include #include #include -#include +#include #include "grib_lookup.h" /* combined lookup structs */ #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/MEL_grib1/ld_grib_origctrs.c b/external/io_grib1/MEL_grib1/ld_grib_origctrs.c index 5429eca235..2db15c4b0d 100644 --- a/external/io_grib1/MEL_grib1/ld_grib_origctrs.c +++ b/external/io_grib1/MEL_grib1/ld_grib_origctrs.c @@ -1,6 +1,13 @@ #include #include #include + +#if defined(_WIN32) +#include +#else +#include +#endif + #include "grib_lookup.h" #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ @@ -153,7 +160,7 @@ FILE *fLook; * * A.7 RETURN with status */ - if (fLook) close(fLook); + if (fLook) fclose(fLook); DPRINT2 ("Exiting %s, Stat=%d\n", func, stat); return (stat); /* diff --git a/external/io_grib1/MEL_grib1/map_lvl.c b/external/io_grib1/MEL_grib1/map_lvl.c index bdbb7651e4..1458d033b9 100644 --- a/external/io_grib1/MEL_grib1/map_lvl.c +++ b/external/io_grib1/MEL_grib1/map_lvl.c @@ -1,5 +1,7 @@ #include #include +#include +#include #include "dprints.h" /* for debug printing */ #include "grib_lookup.h" /* LVL_DEFN */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/MEL_grib1/map_parm.c b/external/io_grib1/MEL_grib1/map_parm.c index 18b2d049ed..83d7ce11b4 100644 --- a/external/io_grib1/MEL_grib1/map_parm.c +++ b/external/io_grib1/MEL_grib1/map_parm.c @@ -1,5 +1,6 @@ #include #include +#include #include "dprints.h" /* for debug printing */ #include "grib_lookup.h" /* PARM_DEFN */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/MEL_grib1/prt_badmsg.c b/external/io_grib1/MEL_grib1/prt_badmsg.c index 2be1ed3383..015806b67b 100644 --- a/external/io_grib1/MEL_grib1/prt_badmsg.c +++ b/external/io_grib1/MEL_grib1/prt_badmsg.c @@ -1,5 +1,6 @@ #include #include +#include #include "gribfuncs.h" /* ************************************************************************** diff --git a/external/io_grib1/MEL_grib1/prt_inp_struct.c b/external/io_grib1/MEL_grib1/prt_inp_struct.c index 250ca780cb..23474ab1ce 100644 --- a/external/io_grib1/MEL_grib1/prt_inp_struct.c +++ b/external/io_grib1/MEL_grib1/prt_inp_struct.c @@ -6,6 +6,7 @@ */ #include #include +#include #include #include "grib_lookup.h" /* for Parm/Ctr/Levl/Mdl_defn */ #include "dprints.h" /* for dprints */ diff --git a/external/io_grib1/MEL_grib1/set_bytes.c b/external/io_grib1/MEL_grib1/set_bytes.c index b7b7aa34c1..6df01fca4b 100644 --- a/external/io_grib1/MEL_grib1/set_bytes.c +++ b/external/io_grib1/MEL_grib1/set_bytes.c @@ -1,4 +1,5 @@ #include +#include #include "isdb.h" void set_bytes(long in, int numbytes, char *out) diff --git a/external/io_grib1/MEL_grib1/upd_child_errmsg.c b/external/io_grib1/MEL_grib1/upd_child_errmsg.c index 500ce68162..d0a795e567 100644 --- a/external/io_grib1/MEL_grib1/upd_child_errmsg.c +++ b/external/io_grib1/MEL_grib1/upd_child_errmsg.c @@ -1,5 +1,6 @@ #include #include +#include #include "dprints.h" /* for dprints */ #include "gribfuncs.h" /* prototypes */ diff --git a/external/io_grib1/Makefile b/external/io_grib1/Makefile index 6afcf4d760..a222b2dbfe 100644 --- a/external/io_grib1/Makefile +++ b/external/io_grib1/Makefile @@ -10,7 +10,7 @@ # # Specity location for Makefiles that are included. # -INCLUDEDIRS = -I. -I./MEL_grib1 -Igrib1_util -I../io_grib_share -I../ +INCLUDEDIRS = -I. -I./MEL_grib1 -Igrib1_util -I../io_grib_share -I../ -I../ioapi_share BUILD_DIR = $(IO_GRIB_SHARE_DIR)../io_grib_share/build # # Specify directory that output library is to be put in. diff --git a/external/io_grib1/WGRIB/CMakeLists.txt b/external/io_grib1/WGRIB/CMakeLists.txt new file mode 100644 index 0000000000..03f53648ff --- /dev/null +++ b/external/io_grib1/WGRIB/CMakeLists.txt @@ -0,0 +1,72 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + # wgrib_main.c # Driver + seekgrib.c + ibm2flt.c + readgrib.c + intpower.c + cnames.c + BDSunpk.c + flt2ieee.c + wrtieee.c + levels.c + PDStimes.c + missing.c + nceptable_reanal.c + nceptable_opn.c + ensemble.c + ombtable.c + ec_ext.c + gribtable.c + gds_grid.c + PDS_date.c + ectable_128.c + ectable_129.c + ectable_130.c + ectable_131.c + ectable_140.c + ectable_150.c + ectable_151.c + ectable_160.c + ectable_170.c + ectable_180.c + nceptab_129.c + dwdtable_002.c + dwdtable_201.c + dwdtable_202.c + dwdtable_203.c + cptectable_254.c + nceptab_130.c + nceptab_131.c + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib1/grib1_routines.c b/external/io_grib1/grib1_routines.c index 37dd19275f..0052cae0f8 100644 --- a/external/io_grib1/grib1_routines.c +++ b/external/io_grib1/grib1_routines.c @@ -16,17 +16,25 @@ #include "grib1_routines.h" #include "gridnav.h" #include "wrf_projection.h" +#include "trim.h" #include #include #include #include +#include +#include +#if defined(_WIN32) +#include +#else +#include +#endif -char *trim (char *str); int index_metadata(GribInfo *gribinfo, MetaData *metadata, int fid); int index_times(GribInfo *gribinfo, Times *times); int find_time(Times *times, char valid_time[15]); int get_gridnav_projection(int wrf_projection); int get_byte(int input_int, int bytenum); +int grib_time_format(char *DateStr, char *DateStrIn); /* * Allocate space for the fileindex structure diff --git a/external/io_grib1/grib1_util/CMakeLists.txt b/external/io_grib1/grib1_util/CMakeLists.txt new file mode 100644 index 0000000000..c480ff8f87 --- /dev/null +++ b/external/io_grib1/grib1_util/CMakeLists.txt @@ -0,0 +1,39 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + alloc_2d.c + read_grib.c + write_grib.c + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_SOURCE_DIR}/../MEL_grib1 + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib1/grib1_util/read_grib.c b/external/io_grib1/grib1_util/read_grib.c index 79757d38d8..c1ebcdcb06 100644 --- a/external/io_grib1/grib1_util/read_grib.c +++ b/external/io_grib1/grib1_util/read_grib.c @@ -49,6 +49,13 @@ #include "gribfuncs.h" #include "gribsize.incl" #include "read_grib.h" +#include "alloc_2d.h" + +#if defined(_WIN32) +#include +#else +#include +#endif /* Function Declarations */ @@ -2267,7 +2274,7 @@ int rg_setup_gribmap(GribParameters *gribmap, char filename[]) gribmap->num_entries = idx; - close(fid); + fclose(fid); return 1; } diff --git a/external/io_grib1/grib1_util/read_grib.h b/external/io_grib1/grib1_util/read_grib.h index f2c628b64b..3a9d73c5cb 100644 --- a/external/io_grib1/grib1_util/read_grib.h +++ b/external/io_grib1/grib1_util/read_grib.h @@ -167,3 +167,4 @@ int rg_get_index_near_date(GribInfo *gribinfo,char targetdate[STRINGSIZE], int rg_get_date(GribInfo *gribinfo,int index); int rg_get_century(GribInfo *gribinfo,int index); int rg_get_forecast_time(GribInfo *gribinfo,int index); +int rg_get_parmtbl(GribInfo *gribinfo, int index); diff --git a/external/io_grib1/grib1_util/write_grib.c b/external/io_grib1/grib1_util/write_grib.c index 79dd956345..29646545cb 100644 --- a/external/io_grib1/grib1_util/write_grib.c +++ b/external/io_grib1/grib1_util/write_grib.c @@ -33,39 +33,14 @@ #include #include +#include #include "gribfuncs.h" -int rg_write_grib(PDS_INPUT *pds, grid_desc_sec *gds, char filename[], - float **data) -{ - char tmpfile[240]; - char tmpstring[240]; - FILE *fid; - int status; - - sprintf(tmpfile,"/tmp/tmpgribfile_%d",getpid()); - fid = fopen(tmpfile,"wb"); - if (fid == NULL) { - fprintf(stderr,"rg_write_grib: Could not open %s\n",tmpfile); - return -1; - } - - status = rg_fwrite_grib(pds,gds,data,fid); - if (status != 1) - { - fprintf(stderr,"rg_write_grib: rg_fwrite_grib failed\n"); - return -1; - } - - /* append tmpfile to filename */ - sprintf(tmpstring,"cat %s >> %s",tmpfile,filename); - system(tmpstring); - unlink(tmpfile); - - close(fid); - - return(1); -} +#if defined(_WIN32) +#include +#else +#include +#endif int rg_fwrite_grib(PDS_INPUT *pds, grid_desc_sec *gds, float **data, FILE *fid) { @@ -188,3 +163,35 @@ int rg_fwrite_grib(PDS_INPUT *pds, grid_desc_sec *gds, float **data, FILE *fid) return 1; } + +int rg_write_grib(PDS_INPUT *pds, grid_desc_sec *gds, char filename[], + float **data) +{ + char tmpfile[240]; + char tmpstring[240]; + FILE *fid; + int status; + + sprintf(tmpfile,"/tmp/tmpgribfile_%d",getpid()); + fid = fopen(tmpfile,"wb"); + if (fid == NULL) { + fprintf(stderr,"rg_write_grib: Could not open %s\n",tmpfile); + return -1; + } + + status = rg_fwrite_grib(pds,gds,data,fid); + if (status != 1) + { + fprintf(stderr,"rg_write_grib: rg_fwrite_grib failed\n"); + return -1; + } + + /* append tmpfile to filename */ + sprintf(tmpstring,"cat %s >> %s",tmpfile,filename); + system(tmpstring); + unlink(tmpfile); + + fclose(fid); + + return(1); +} diff --git a/external/io_grib1/gribmap.c b/external/io_grib1/gribmap.c index 0ad686c2fc..bfd0aa30df 100644 --- a/external/io_grib1/gribmap.c +++ b/external/io_grib1/gribmap.c @@ -1,6 +1,8 @@ #include #include +#include #include "gribmap.h" +#include "trim.h" /****************************************************************************** * diff --git a/external/io_grib1/gribmap.h b/external/io_grib1/gribmap.h index 24b56f1aca..3dd0cf32a3 100644 --- a/external/io_grib1/gribmap.h +++ b/external/io_grib1/gribmap.h @@ -52,5 +52,6 @@ int GET_GRIB1_TABLES_SIZE (int *size); int LOAD_GRIB1_TABLES (char filename[], Grib1_Tables *grib_tables, int *ret, int strlen1); +int FREE_GRIBMAP(Grib1_Tables *grib_tables); Grib1_Tables *copy_grib_tables(Grib1_Tables *); diff --git a/external/io_grib1/trim.c b/external/io_grib1/trim.c index cb219ad645..3f06fbe472 100644 --- a/external/io_grib1/trim.c +++ b/external/io_grib1/trim.c @@ -1,5 +1,6 @@ #include #include +#include char *trim (char *str) { diff --git a/external/io_grib1/trim.h b/external/io_grib1/trim.h new file mode 100644 index 0000000000..550f765a5f --- /dev/null +++ b/external/io_grib1/trim.h @@ -0,0 +1,2 @@ +char *trim (char *str); + diff --git a/external/io_grib1/wrf_status_codes.h b/external/io_grib1/wrf_status_codes.h deleted file mode 100644 index 059d9ea719..0000000000 --- a/external/io_grib1/wrf_status_codes.h +++ /dev/null @@ -1,133 +0,0 @@ - -!WRF Error and Warning messages (1-999) -!All i/o package-specific status codes you may want to add must be handled by your package (see below) -! WRF handles these and netCDF messages only - integer, parameter :: WRF_NO_ERR = 0 !no error - integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete - integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found - integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found - integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps - integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found - integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time - integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files - integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch - integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file - integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file - integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file - integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable - integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF - integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle - integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length - integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training - integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists - integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent - integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized - integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths - integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage - integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable - integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP - -!Fatal errors - integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error - integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error - integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status - - -!Package specific errors (1000+) -!Netcdf status codes -!WRF will accept status codes of 1000+, but it is up to the package to handle -! and return the status to the user. - - integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 - integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 - integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 - integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 - integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 - integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 - integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 - integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 - integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 - integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 - integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 - integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 - integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 - integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 - integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 - integer, parameter :: WRF_WARN_NETCDF = -1021 - integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 - integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 - integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 - -! For HDF5 only - integer, parameter :: WRF_HDF5_ERR_FILE = -200 - integer, parameter :: WRF_HDF5_ERR_MD = -201 - integer, parameter :: WRF_HDF5_ERR_TIME = -202 - integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 - integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 - integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 - integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 - integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 - integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 - integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 - integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 - integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 - integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 - integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 - integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 - integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 - integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 - integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 - integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 - integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 - integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 - integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 - - integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 - integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 - integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 - integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 - integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 - integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 - - integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 - integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 - integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 - - integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 - integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 - integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 - integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 - integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 - integer, parameter :: WRF_HDF5_ERR_GROUP = -308 - - integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 - integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 - integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 - integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 - integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 - - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 - - integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 - diff --git a/external/io_grib2/CMakeLists.txt b/external/io_grib2/CMakeLists.txt new file mode 100644 index 0000000000..2a85c86094 --- /dev/null +++ b/external/io_grib2/CMakeLists.txt @@ -0,0 +1,13 @@ +# WRF CMake Build + +# Eventually switch to ncep tag on github but for now make this 1-to-1 with make-style WRF +add_subdirectory( g2lib ) +add_subdirectory( bacio-1.3 ) + +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + grib2tbls_types.F + io_grib2.F + read_grib2map.F + ) diff --git a/external/io_grib2/bacio-1.3/CMakeLists.txt b/external/io_grib2/bacio-1.3/CMakeLists.txt new file mode 100644 index 0000000000..450cb510ed --- /dev/null +++ b/external/io_grib2/bacio-1.3/CMakeLists.txt @@ -0,0 +1,43 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + bacio.v1.3.c + baciof.F + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib2/g2lib/CMakeLists.txt b/external/io_grib2/g2lib/CMakeLists.txt new file mode 100644 index 0000000000..70246d4d16 --- /dev/null +++ b/external/io_grib2/g2lib/CMakeLists.txt @@ -0,0 +1,109 @@ +# WRF CMake Build +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + addfield.F + addgrid.F + addlocal.F + cmplxpack.F + compack.F + comunpack.F + dec_jpeg2000.c + dec_png.c + drstemplates.F + enc_jpeg2000.c + enc_png.c + g2grids.F + gb_info.F + gbytesc.F + gdt2gds.F + getdim.F + getfield.F + getg2i.F + getg2ir.F + getgb2.F + getgb2l.F + getgb2p.F + getgb2r.F + getgb2rp.F + getgb2s.F + getidx.F + getlocal.F + getpoly.F + gettemplates.F + gf_free.F + gf_getfld.F + gf_unpack1.F + gf_unpack2.F + gf_unpack3.F + gf_unpack4.F + gf_unpack5.F + gf_unpack6.F + gf_unpack7.F + gribcreate.F + gribend.F + gribinfo.F + gribmod.F + gridtemplates.F + ixgb2.F + jpcpack.F + jpcunpack.F + misspack.F + mkieee.F + mova2i.c + pack_gp.F + params.F + pdstemplates.F + pngpack.F + pngunpack.F + putgb2.F + rdieee.F + realloc.F + reduce.F + simpack.F + simunpack.F + skgb.F + specpack.F + specunpack.F + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + # Fortran_FORMAT FREE + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + $ + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + #!TODO Fix duplicates of wrf_[io|status]_flags.h + # ${CMAKE_CURRENT_SOURCE_DIR}/../ioapi_share + ${CMAKE_CURRENT_SOURCE_DIR}/../io_grib_share + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_grib2/g2lib/dec_png.c b/external/io_grib2/g2lib/dec_png.c index aa85184b36..a33c0c0ac6 100644 --- a/external/io_grib2/g2lib/dec_png.c +++ b/external/io_grib2/g2lib/dec_png.c @@ -88,7 +88,7 @@ int DEC_PNG(unsigned char *pngbuf,g2int *width,g2int *height,char *cout) /* Set new custom read function */ - png_set_read_fn(png_ptr,(voidp)&read_io_ptr,(png_rw_ptr)user_read_data); + png_set_read_fn(png_ptr,(png_voidp)&read_io_ptr,(png_rw_ptr)user_read_data); /* png_init_io(png_ptr, fptr); */ /* Read and decode PNG stream */ diff --git a/external/io_grib2/g2lib/enc_png.c b/external/io_grib2/g2lib/enc_png.c index 7d2ef1d287..97d0b961a9 100644 --- a/external/io_grib2/g2lib/enc_png.c +++ b/external/io_grib2/g2lib/enc_png.c @@ -88,7 +88,7 @@ int ENC_PNG(char *data,g2int *width,g2int *height,g2int *nbits,char *pngbuf) /* Set new custom write functions */ - png_set_write_fn(png_ptr,(voidp)&write_io_ptr,(png_rw_ptr)user_write_data, + png_set_write_fn(png_ptr,(png_voidp)&write_io_ptr,(png_rw_ptr)user_write_data, (png_flush_ptr)user_flush_data); /* png_init_io(png_ptr, fptr); */ /* png_set_compression_level(png_ptr, Z_BEST_COMPRESSION); */ diff --git a/external/io_grib2/g2lib/utest/CMakeLists.txt b/external/io_grib2/g2lib/utest/CMakeLists.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/external/io_grib_share/CMakeLists.txt b/external/io_grib_share/CMakeLists.txt new file mode 100644 index 0000000000..f62d453e8b --- /dev/null +++ b/external/io_grib_share/CMakeLists.txt @@ -0,0 +1,48 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + io_grib_share.F + get_region_center.c + gridnav.c + open_file.c + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + Fortran_FORMAT FREE + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_SOURCE_DIR}/../ioapi_share + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) \ No newline at end of file diff --git a/external/io_grib_share/Makefile b/external/io_grib_share/Makefile index 41d3c96659..5e3a59db55 100644 --- a/external/io_grib_share/Makefile +++ b/external/io_grib_share/Makefile @@ -22,9 +22,9 @@ LIB_DEST = . # CXX_INCLUDES is for C++ files # C_INCLUDES is for C files # -C_INCLUDES = -I. -CXX_INCLUDES = -I. -F_INCLUDES = -I. +C_INCLUDES = -I. -I../ioapi_share +CXX_INCLUDES = -I. -I../ioapi_share +F_INCLUDES = -I. -I../ioapi_share AR = ar ARFLAGS = cruv diff --git a/external/io_grib_share/get_region_center.c b/external/io_grib_share/get_region_center.c index d708656c1e..68ad5f7bc5 100644 --- a/external/io_grib_share/get_region_center.c +++ b/external/io_grib_share/get_region_center.c @@ -2,6 +2,7 @@ #include "gridnav.h" #include #include +#include #include "wrf_projection.h" diff --git a/external/io_grib_share/open_file.c b/external/io_grib_share/open_file.c index 673b8ff544..b629bddfd8 100644 --- a/external/io_grib_share/open_file.c +++ b/external/io_grib_share/open_file.c @@ -1,9 +1,12 @@ #include #include #include - #ifdef _WIN32 #include +#include +#else +#include +#include #endif #ifndef CRAY diff --git a/external/io_grib_share/wrf_io_flags.h b/external/io_grib_share/wrf_io_flags.h deleted file mode 100644 index 708939f914..0000000000 --- a/external/io_grib_share/wrf_io_flags.h +++ /dev/null @@ -1,16 +0,0 @@ - integer, parameter :: WRF_FILE_NOT_OPENED = 100 - integer, parameter :: WRF_FILE_OPENED_NOT_COMMITTED = 101 - integer, parameter :: WRF_FILE_OPENED_FOR_WRITE = 102 - integer, parameter :: WRF_FILE_OPENED_FOR_READ = 103 - integer, parameter :: WRF_REAL = 104 - integer, parameter :: WRF_DOUBLE = 105 -#ifdef PROMOTE_FLOAT - integer, parameter :: WRF_FLOAT=WRF_DOUBLE -#else - integer, parameter :: WRF_FLOAT=WRF_REAL -#endif - integer, parameter :: WRF_INTEGER = 106 - integer, parameter :: WRF_LOGICAL = 107 - integer, parameter :: WRF_COMPLEX = 108 - integer, parameter :: WRF_DOUBLE_COMPLEX = 109 - integer, parameter :: WRF_FILE_OPENED_FOR_UPDATE = 110 diff --git a/external/io_grib_share/wrf_status_codes.h b/external/io_grib_share/wrf_status_codes.h deleted file mode 100644 index 008ac5ce76..0000000000 --- a/external/io_grib_share/wrf_status_codes.h +++ /dev/null @@ -1,142 +0,0 @@ - -!WRF Error and Warning messages (1-999) -!All i/o package-specific status codes you may want to add must be handled by your package (see below) -! WRF handles these and netCDF messages only - integer, parameter :: WRF_NO_ERR = 0 !no error - integer, parameter :: WRF_WARN_FILE_NF = -1 !file not found, or incomplete - integer, parameter :: WRF_WARN_MD_NF = -2 !metadata not found - integer, parameter :: WRF_WARN_TIME_NF = -3 !timestamp not found - integer, parameter :: WRF_WARN_TIME_EOF = -4 !no more timestamps - integer, parameter :: WRF_WARN_VAR_NF = -5 !variable not found - integer, parameter :: WRF_WARN_VAR_EOF = -6 !no more variables for the current time - integer, parameter :: WRF_WARN_TOO_MANY_FILES = -7 !too many open files - integer, parameter :: WRF_WARN_TYPE_MISMATCH = -8 !data type mismatch - integer, parameter :: WRF_WARN_WRITE_RONLY_FILE = -9 !attempt to write readonly file - integer, parameter :: WRF_WARN_READ_WONLY_FILE = -10 !attempt to read writeonly file - integer, parameter :: WRF_WARN_FILE_NOT_OPENED = -11 !attempt to access unopened file - integer, parameter :: WRF_WARN_2DRYRUNS_1VARIABLE = -12 !attempt to do 2 trainings for 1 variable - integer, parameter :: WRF_WARN_READ_PAST_EOF = -13 !attempt to read past EOF - integer, parameter :: WRF_WARN_BAD_DATA_HANDLE = -14 !bad data handle - integer, parameter :: WRF_WARN_WRTLEN_NE_DRRUNLEN = -15 !write length not equal to training length - integer, parameter :: WRF_WARN_TOO_MANY_DIMS = -16 !more dimensions requested than training - integer, parameter :: WRF_WARN_COUNT_TOO_LONG = -17 !attempt to read more data than exists - integer, parameter :: WRF_WARN_DIMENSION_ERROR = -18 !input dimension inconsistent - integer, parameter :: WRF_WARN_BAD_MEMORYORDER = -19 !input MemoryOrder not recognized - integer, parameter :: WRF_WARN_DIMNAME_REDEFINED = -20 !a dimension name with 2 different lengths - integer, parameter :: WRF_WARN_CHARSTR_GT_LENDATA = -21 !string longer than provided storage - integer, parameter :: WRF_WARN_NOTSUPPORTED = -22 !function not supportable - integer, parameter :: WRF_WARN_NOOP = -23 !package implements this routine as NOOP - -!Fatal errors - integer, parameter :: WRF_ERR_FATAL_ALLOCATION_ERROR = -100 !allocation error - integer, parameter :: WRF_ERR_FATAL_DEALLOCATION_ERR = -101 !dealloc error - integer, parameter :: WRF_ERR_FATAL_BAD_FILE_STATUS = -102 !bad file status - - -!Package specific errors (1000+) -!Netcdf status codes -!WRF will accept status codes of 1000+, but it is up to the package to handle -! and return the status to the user. - - integer, parameter :: WRF_ERR_FATAL_BAD_VARIABLE_DIM = -1004 - integer, parameter :: WRF_ERR_FATAL_MDVAR_DIM_NOT_1D = -1005 - integer, parameter :: WRF_ERR_FATAL_TOO_MANY_TIMES = -1006 - integer, parameter :: WRF_WARN_BAD_DATA_TYPE = -1007 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_NOT_COMMITTED = -1008 !this code not in either spec? - integer, parameter :: WRF_WARN_FILE_OPEN_FOR_READ = -1009 - integer, parameter :: WRF_IO_NOT_INITIALIZED = -1010 - integer, parameter :: WRF_WARN_MD_AFTER_OPEN = -1011 - integer, parameter :: WRF_WARN_TOO_MANY_VARIABLES = -1012 - integer, parameter :: WRF_WARN_DRYRUN_CLOSE = -1013 - integer, parameter :: WRF_WARN_DATESTR_BAD_LENGTH = -1014 - integer, parameter :: WRF_WARN_ZERO_LENGTH_READ = -1015 - integer, parameter :: WRF_WARN_DATA_TYPE_NOT_FOUND = -1016 - integer, parameter :: WRF_WARN_DATESTR_ERROR = -1017 - integer, parameter :: WRF_WARN_DRYRUN_READ = -1018 - integer, parameter :: WRF_WARN_ZERO_LENGTH_GET = -1019 - integer, parameter :: WRF_WARN_ZERO_LENGTH_PUT = -1020 - integer, parameter :: WRF_WARN_NETCDF = -1021 - integer, parameter :: WRF_WARN_LENGTH_LESS_THAN_1 = -1022 - integer, parameter :: WRF_WARN_MORE_DATA_IN_FILE = -1023 - integer, parameter :: WRF_WARN_DATE_LT_LAST_DATE = -1024 - -! For HDF5 only - integer, parameter :: WRF_HDF5_ERR_FILE = -200 - integer, parameter :: WRF_HDF5_ERR_MD = -201 - integer, parameter :: WRF_HDF5_ERR_TIME = -202 - integer, parameter :: WRF_HDF5_ERR_TIME_EOF = -203 - integer, parameter :: WRF_HDF5_ERR_MORE_DATA_IN_FILE = -204 - integer, parameter :: WRF_HDF5_ERR_DATE_LT_LAST_DATE = -205 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_FILES = -206 - integer, parameter :: WRF_HDF5_ERR_TYPE_MISMATCH = -207 - integer, parameter :: WRF_HDF5_ERR_LENGTH_LESS_THAN_1 = -208 - integer, parameter :: WRF_HDF5_ERR_WRITE_RONLY_FILE = -209 - integer, parameter :: WRF_HDF5_ERR_READ_WONLY_FILE = -210 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_OPENED = -211 - integer, parameter :: WRF_HDF5_ERR_DATESTR_ERROR = -212 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_READ = -213 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_GET = -214 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_PUT = -215 - integer, parameter :: WRF_HDF5_ERR_2DRYRUNS_1VARIABLE = -216 - integer, parameter :: WRF_HDF5_ERR_DATA_TYPE_NOTFOUND = -217 - integer, parameter :: WRF_HDF5_ERR_READ_PAST_EOF = -218 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_HANDLE = -219 - integer, parameter :: WRF_HDF5_ERR_WRTLEN_NE_DRRUNLEN = -220 - integer, parameter :: WRF_HDF5_ERR_DRYRUN_CLOSE = -221 - integer, parameter :: WRF_HDF5_ERR_DATESTR_BAD_LENGTH = -222 - integer, parameter :: WRF_HDF5_ERR_ZERO_LENGTH_READ = -223 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_DIMS = -224 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_VARIABLES = -225 - integer, parameter :: WRF_HDF5_ERR_COUNT_TOO_LONG = -226 - integer, parameter :: WRF_HDF5_ERR_DIMENSION_ERROR = -227 - integer, parameter :: WRF_HDF5_ERR_BAD_MEMORYORDER = -228 - integer, parameter :: WRF_HDF5_ERR_DIMNAME_REDEFINED = -229 - integer, parameter :: WRF_HDF5_ERR_MD_AFTER_OPEN = -230 - integer, parameter :: WRF_HDF5_ERR_CHARSTR_GT_LENDATA = -231 - integer, parameter :: WRF_HDF5_ERR_BAD_DATA_TYPE = -232 - integer, parameter :: WRF_HDF5_ERR_FILE_NOT_COMMITTED = -233 - - integer, parameter :: WRF_HDF5_ERR_ALLOCATION = -2001 - integer, parameter :: WRF_HDF5_ERR_DEALLOCATION = -2002 - integer, parameter :: WRF_HDF5_ERR_BAD_FILE_STATUS = -2003 - integer, parameter :: WRF_HDF5_ERR_BAD_VARIABLE_DIM = -2004 - integer, parameter :: WRF_HDF5_ERR_MDVAR_DIM_NOT_1D = -2005 - integer, parameter :: WRF_HDF5_ERR_TOO_MANY_TIMES = -2006 - integer, parameter :: WRF_HDF5_ERR_DATA_ID_NOTFOUND = -2007 - - integer, parameter :: WRF_HDF5_ERR_DATASPACE = -300 - integer, parameter :: WRF_HDF5_ERR_DATATYPE = -301 - integer, parameter :: WRF_HDF5_ERR_PROPERTY_LIST = -302 - - integer, parameter :: WRF_HDF5_ERR_DATASET_CREATE = -303 - integer, parameter :: WRF_HDF5_ERR_DATASET_READ = -304 - integer, parameter :: WRF_HDF5_ERR_DATASET_WRITE = -305 - integer, parameter :: WRF_HDF5_ERR_DATASET_OPEN = -306 - integer, parameter :: WRF_HDF5_ERR_DATASET_GENERAL = -307 - integer, parameter :: WRF_HDF5_ERR_GROUP = -308 - - integer, parameter :: WRF_HDF5_ERR_FILE_OPEN = -309 - integer, parameter :: WRF_HDF5_ERR_FILE_CREATE = -310 - integer, parameter :: WRF_HDF5_ERR_DATASET_CLOSE = -311 - integer, parameter :: WRF_HDF5_ERR_FILE_CLOSE = -312 - integer, parameter :: WRF_HDF5_ERR_CLOSE_GENERAL = -313 - - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CREATE = -314 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_READ = -315 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_WRITE = -316 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OPEN = -317 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_GENERAL = -318 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_CLOSE = -319 - - integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 - integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 - - integer, parameter :: WRF_GRIB2_ERR_GRIBCREATE = -401 - integer, parameter :: WRF_GRIB2_ERR_ADDLOCAL = -402 - integer, parameter :: WRF_GRIB2_ERR_ADDGRIB = -403 - integer, parameter :: WRF_GRIB2_ERR_ADDFIELD = -404 - integer, parameter :: WRF_GRIB2_ERR_GRIBEND = -405 - integer, parameter :: WRF_GRIB2_ERR_WRITE = -406 - integer, parameter :: WRF_GRIB2_ERR_GRIB2MAP = -407 - integer, parameter :: WRF_GRIB2_ERR_GETGB2 = -408 - integer, parameter :: WRF_GRIB2_ERR_READ = -409 diff --git a/external/io_int/CMakeLists.txt b/external/io_int/CMakeLists.txt new file mode 100644 index 0000000000..933e5fe421 --- /dev/null +++ b/external/io_int/CMakeLists.txt @@ -0,0 +1,83 @@ +# WRF CMake Build +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + io_int.F90 + io_int_idx.c + module_io_int_idx.F90 + module_io_int_read.F90 + ${PROJECT_SOURCE_DIR}/frame/module_internal_header_util.F + ) + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + Fortran_FORMAT FREE + ) + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PUBLIC + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PUBLIC + $ + $ + $ + $ + $ + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +# Now build diffwrf +set( DIFFWRF_TARGET diffwrf_int ) +add_executable( + ${DIFFWRF_TARGET} + diffwrf.F90 + ${PROJECT_SOURCE_DIR}/frame/module_machine.F + ${PROJECT_SOURCE_DIR}/frame/module_driver_constants.F + ${PROJECT_SOURCE_DIR}/frame/pack_utils.c + ${PROJECT_SOURCE_DIR}/frame/module_wrf_error.F + ${PROJECT_SOURCE_DIR}/frame/wrf_debug.F + ) + +target_link_libraries( + ${DIFFWRF_TARGET} + PRIVATE + ${FOLDER_COMPILE_TARGET} + ) + +target_include_directories( + ${DIFFWRF_TARGET} + PRIVATE + ${CMAKE_BINARY_DIR}/inc + ) + +set_target_properties( + ${DIFFWRF_TARGET} + PROPERTIES + # Just dump everything in here + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/modules/${DIFFWRF_TARGET} + Fortran_FORMAT FREE + ) + +add_dependencies( ${DIFFWRF_TARGET} registry_code ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} ${DIFFWRF_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_int/io_int.F90 b/external/io_int/io_int.F90 index e57224b51e..ab95b49a45 100644 --- a/external/io_int/io_int.F90 +++ b/external/io_int/io_int.F90 @@ -9,6 +9,8 @@ ! Uses header manipulation routines in module_io_quilt.F ! +#include "intio_tags.h" + MODULE module_ext_internal USE module_internal_header_util @@ -168,7 +170,7 @@ SUBROUTINE ext_int_open_for_write( FileName , Comm_compute, Comm_io, SysDepInfo, DataHandle , Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + CHARACTER*(*) :: FileName INTEGER , INTENT(IN) :: Comm_compute , Comm_io CHARACTER*(*) :: SysDepInfo @@ -187,7 +189,7 @@ SUBROUTINE ext_int_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDe DataHandle , Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + #include "wrf_io_flags.h" CHARACTER*(*) :: FileName INTEGER , INTENT(IN) :: Comm_compute , Comm_io @@ -221,7 +223,7 @@ END SUBROUTINE ext_int_open_for_write_begin SUBROUTINE ext_int_open_for_write_commit( DataHandle , Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + #include "wrf_io_flags.h" INTEGER , INTENT(IN ) :: DataHandle INTEGER , INTENT(OUT) :: Status @@ -362,7 +364,7 @@ SUBROUTINE ext_int_ioexit( Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(OUT) :: Status INTEGER :: DataHandle INTEGER i,ierr @@ -375,7 +377,7 @@ END SUBROUTINE ext_int_ioexit SUBROUTINE ext_int_get_next_time ( DataHandle, DateStr, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStr INTEGER , INTENT(OUT) :: Status @@ -417,7 +419,7 @@ SUBROUTINE ext_int_get_next_time ( DataHandle, DateStr, Status ) READ( unit=DataHandle, iostat=istat ) hdrbuf ! this is okay as long as no other record type has data that follows IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_field ) THEN + IF ( code .EQ. INT_FIELD ) THEN CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, & locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm, & locDomainDesc , locMemoryOrder , locStagger , locDimNames , & @@ -433,7 +435,7 @@ SUBROUTINE ext_int_get_next_time ( DataHandle, DateStr, Status ) ELSE READ( unit=DataHandle, iostat=istat ) ENDIF - ELSE IF ( code .EQ. int_dom_td_char ) THEN + ELSE IF ( code .EQ. INT_DOM_TD_CHAR ) THEN CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, & locDataHandle, locDateStr, locElement, locData, loccode ) IF ( TRIM(locDateStr) .NE. TRIM(CurrentDateInFile(DataHandle) ) ) THEN ! control break, return this date @@ -460,13 +462,13 @@ END SUBROUTINE ext_int_get_next_time SUBROUTINE ext_int_set_time ( DataHandle, DateStr, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStr INTEGER , INTENT(OUT) :: Status CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, "TIMESTAMP", "", TRIM(DateStr), int_set_time ) + DataHandle, "TIMESTAMP", "", TRIM(DateStr), INT_SET_TIME ) WRITE( unit=DataHandle ) hdrbuf Status = 0 RETURN @@ -477,7 +479,7 @@ SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , St DomainStart , DomainEnd , WrfType, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + integer ,intent(in) :: DataHandle character*(*) ,intent(in) :: VarName integer ,intent(out) :: NDim @@ -519,7 +521,7 @@ SUBROUTINE ext_int_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , St READ( unit=DataHandle, iostat=istat ) hdrbuf ! this is okay as long as no other record type has data that follows IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_field ) THEN + IF ( code .EQ. INT_FIELD ) THEN CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, & locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm, & locDomainDesc , MemoryOrder , locStagger , locDimNames , & @@ -561,7 +563,7 @@ END SUBROUTINE ext_int_get_var_info SUBROUTINE ext_int_get_next_var ( DataHandle, VarName, Status ) USE module_ext_internal IMPLICIT NONE - include 'intio_tags.h' + include 'wrf_status_codes.h' INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: VarName @@ -606,20 +608,20 @@ SUBROUTINE ext_int_get_next_var ( DataHandle, VarName, Status ) IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) #if 1 - IF ( code .EQ. int_dom_ti_char ) THEN + IF ( code .EQ. INT_DOM_TI_CHAR ) THEN CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, & locDataHandle, locElement, dumstr, strData, loccode ) ENDIF - IF ( code .EQ. int_dom_ti_integer ) THEN + IF ( code .EQ. INT_DOM_TI_INTEGER ) THEN CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, & locDataHandle, locElement, iData, loccount, code ) ENDIF - IF ( code .EQ. int_dom_ti_real ) THEN + IF ( code .EQ. INT_DOM_TI_REAL ) THEN CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, & locDataHandle, locElement, rData, loccount, code ) ENDIF #endif - IF ( code .EQ. int_field ) THEN + IF ( code .EQ. INT_FIELD ) THEN CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, & locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm, & locDomainDesc , locMemoryOrder , locStagger , locDimNames , & @@ -660,7 +662,7 @@ END SUBROUTINE ext_int_get_next_var SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element REAL , INTENT(OUT) :: Data(*) @@ -681,7 +683,7 @@ SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount READ( unit=DataHandle , iostat = istat ) hdrbuf IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_dom_ti_real ) THEN + IF ( code .EQ. INT_DOM_TI_REAL ) THEN CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, & locDataHandle, locElement, Data, loccount, code ) IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN @@ -690,11 +692,11 @@ SUBROUTINE ext_int_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount ENDIF keepgoing = .false. ; Status = 0 ENDIF - ELSE IF ( .NOT. ( code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_logical .OR. & - code .EQ. int_dom_ti_char .OR. code .EQ. int_dom_ti_double .OR. & - code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_logical .OR. & - code .EQ. int_dom_td_char .OR. code .EQ. int_dom_td_double .OR. & - code .EQ. int_dom_td_real ) ) THEN + ELSE IF ( .NOT. ( code .EQ. INT_DOM_TI_INTEGER .OR. code .EQ. INT_DOM_TI_LOGICAL .OR. & + code .EQ. INT_DOM_TI_CHAR .OR. code .EQ. INT_DOM_TI_DOUBLE .OR. & + code .EQ. INT_DOM_TD_INTEGER .OR. code .EQ. INT_DOM_TD_LOGICAL .OR. & + code .EQ. INT_DOM_TD_CHAR .OR. code .EQ. INT_DOM_TD_DOUBLE .OR. & + code .EQ. INT_DOM_TD_REAL ) ) THEN BACKSPACE ( unit=DataHandle ) keepgoing = .false. ; Status = 2 ENDIF @@ -712,7 +714,7 @@ END SUBROUTINE ext_int_get_dom_ti_real SUBROUTINE ext_int_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element REAL , INTENT(IN) :: Data(*) @@ -726,7 +728,7 @@ SUBROUTINE ext_int_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ! Do nothing unless it is time to write time-independent domain metadata. IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, & - DataHandle, Element, Data, Count, int_dom_ti_real ) + DataHandle, Element, Data, Count, INT_DOM_TI_REAL ) WRITE( unit=DataHandle ) hdrbuf ENDIF ENDIF @@ -772,7 +774,7 @@ END SUBROUTINE ext_int_put_dom_ti_double SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element integer , INTENT(OUT) :: Data(*) @@ -793,7 +795,7 @@ SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outco READ( unit=DataHandle , iostat = istat ) hdrbuf IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_dom_ti_integer ) THEN + IF ( code .EQ. INT_DOM_TI_INTEGER ) THEN CALL int_get_ti_header( hdrbuf, hdrbufsize, itypesize, rtypesize, & locDataHandle, locElement, Data, loccount, code ) IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN @@ -803,11 +805,11 @@ SUBROUTINE ext_int_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outco keepgoing = .false. ; Status = 0 ENDIF - ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real .OR. code .EQ. int_dom_ti_logical .OR. & - code .EQ. int_dom_ti_char .OR. code .EQ. int_dom_ti_double .OR. & - code .EQ. int_dom_td_real .OR. code .EQ. int_dom_td_logical .OR. & - code .EQ. int_dom_td_char .OR. code .EQ. int_dom_td_double .OR. & - code .EQ. int_dom_td_integer ) ) THEN + ELSE IF ( .NOT. ( code .EQ. INT_DOM_TI_REAL .OR. code .EQ. INT_DOM_TI_LOGICAL .OR. & + code .EQ. INT_DOM_TI_CHAR .OR. code .EQ. INT_DOM_TI_DOUBLE .OR. & + code .EQ. INT_DOM_TD_REAL .OR. code .EQ. INT_DOM_TD_LOGICAL .OR. & + code .EQ. INT_DOM_TD_CHAR .OR. code .EQ. INT_DOM_TD_DOUBLE .OR. & + code .EQ. INT_DOM_TD_INTEGER ) ) THEN BACKSPACE ( unit=DataHandle ) keepgoing = .false. ; Status = 1 ENDIF @@ -825,7 +827,7 @@ END SUBROUTINE ext_int_get_dom_ti_integer SUBROUTINE ext_int_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element INTEGER , INTENT(IN) :: Data(*) @@ -838,7 +840,7 @@ SUBROUTINE ext_int_put_dom_ti_integer ( DataHandle,Element, Data, Count, Stat ! Do nothing unless it is time to write time-independent domain metadata. IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, itypesize, & - DataHandle, Element, Data, Count, int_dom_ti_integer ) + DataHandle, Element, Data, Count, INT_DOM_TI_INTEGER ) WRITE( unit=DataHandle ) hdrbuf ENDIF ENDIF @@ -884,7 +886,7 @@ END SUBROUTINE ext_int_put_dom_ti_logical SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element, Data, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: Data @@ -905,17 +907,17 @@ SUBROUTINE ext_int_get_dom_ti_char ( DataHandle,Element, Data, Status ) IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_dom_ti_char ) THEN + IF ( code .EQ. INT_DOM_TI_CHAR ) THEN CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, & locDataHandle, locElement, dumstr, Data, code ) IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN keepgoing = .false. ; Status = 0 ENDIF - ELSE IF ( .NOT. ( code .EQ. int_dom_ti_real .OR. code .EQ. int_dom_ti_logical .OR. & - code .EQ. int_dom_ti_integer .OR. code .EQ. int_dom_ti_double .OR. & - code .EQ. int_dom_td_real .OR. code .EQ. int_dom_td_logical .OR. & - code .EQ. int_dom_td_integer .OR. code .EQ. int_dom_td_double .OR. & - code .EQ. int_dom_td_char ) ) THEN + ELSE IF ( .NOT. ( code .EQ. INT_DOM_TI_REAL .OR. code .EQ. INT_DOM_TI_LOGICAL .OR. & + code .EQ. INT_DOM_TI_INTEGER .OR. code .EQ. INT_DOM_TI_DOUBLE .OR. & + code .EQ. INT_DOM_TD_REAL .OR. code .EQ. INT_DOM_TD_LOGICAL .OR. & + code .EQ. INT_DOM_TD_INTEGER .OR. code .EQ. INT_DOM_TD_DOUBLE .OR. & + code .EQ. INT_DOM_TD_CHAR ) ) THEN BACKSPACE ( unit=DataHandle ) keepgoing = .false. ; Status = 1 ENDIF @@ -933,7 +935,7 @@ END SUBROUTINE ext_int_get_dom_ti_char SUBROUTINE ext_int_put_dom_ti_char ( DataHandle, Element, Data, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: Data @@ -947,7 +949,7 @@ SUBROUTINE ext_int_put_dom_ti_char ( DataHandle, Element, Data, Status ) ! Do nothing unless it is time to write time-independent domain metadata. IF ( int_ok_to_put_dom_ti( DataHandle ) ) THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, Element, "", Data, int_dom_ti_char ) + DataHandle, Element, "", Data, INT_DOM_TI_CHAR ) WRITE( unit=DataHandle ) hdrbuf ENDIF ENDIF @@ -1062,7 +1064,7 @@ END SUBROUTINE ext_int_put_dom_td_logical SUBROUTINE ext_int_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: Data, DateStr @@ -1080,7 +1082,7 @@ SUBROUTINE ext_int_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_dom_td_char ) THEN + IF ( code .EQ. INT_DOM_TD_CHAR ) THEN CALL int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, & locDataHandle, locDateStr, locElement, Data, code ) IF ( TRIM(locElement) .EQ. TRIM(Element) ) THEN @@ -1103,7 +1105,7 @@ END SUBROUTINE ext_int_get_dom_td_char SUBROUTINE ext_int_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: Data, DateStr @@ -1114,7 +1116,7 @@ SUBROUTINE ext_int_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status IF ( int_valid_handle ( Datahandle ) ) THEN IF ( int_handle_in_use( DataHandle ) ) THEN CALL int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, DateStr, Element, Data, int_dom_td_char ) + DataHandle, DateStr, Element, Data, INT_DOM_TD_CHAR ) WRITE( unit=DataHandle ) hdrbuf ENDIF ENDIF @@ -1178,7 +1180,7 @@ END SUBROUTINE ext_int_put_var_ti_double SUBROUTINE ext_int_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) USE module_ext_internal IMPLICIT NONE -#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: VarName @@ -1192,7 +1194,7 @@ SUBROUTINE ext_int_get_var_ti_integer ( DataHandle,Element, Varname, Data, Coun IF ( int_handle_in_use( DataHandle ) ) THEN READ( unit=DataHandle ) hdrbuf code=hdrbuf(2) - IF ( code .NE. int_var_ti_integer ) THEN + IF ( code .NE. INT_VAR_TI_INTEGER ) THEN BACKSPACE ( unit=DataHandle ) write(*,*) 'unexpected code=',code,' in ext_int_get_var_ti_integer' Status = 1 @@ -1219,7 +1221,7 @@ SUBROUTINE ext_int_put_var_ti_integer ( DataHandle,Element, Varname, Data, Coun USE module_ext_internal USE module_internal_header_util, only: int_gen_ti_header_integer_varna IMPLICIT NONE -#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: VarName @@ -1230,7 +1232,7 @@ SUBROUTINE ext_int_put_var_ti_integer ( DataHandle,Element, Varname, Data, Coun IF ( int_handle_in_use( DataHandle ) ) THEN CALL int_gen_ti_header_integer_varna( hdrbuf, hdrbufsize, itypesize,4, & DataHandle, TRIM(Element), TRIM(VarName), Data, Count, & - int_var_ti_integer ) + INT_VAR_TI_INTEGER ) WRITE( unit=DataHandle ) hdrbuf ENDIF ENDIF @@ -1267,7 +1269,7 @@ END SUBROUTINE ext_int_put_var_ti_logical SUBROUTINE ext_int_get_var_ti_char ( DataHandle,Element, Varname, Data, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: VarName @@ -1279,7 +1281,7 @@ SUBROUTINE ext_int_get_var_ti_char ( DataHandle,Element, Varname, Data, Status IF ( int_handle_in_use( DataHandle ) ) THEN READ( unit=DataHandle ) hdrbuf code=hdrbuf(2) - IF ( code .NE. int_var_ti_char ) THEN + IF ( code .NE. INT_VAR_TI_CHAR ) THEN BACKSPACE ( unit=DataHandle ) Status = 1 return @@ -1302,7 +1304,7 @@ END SUBROUTINE ext_int_get_var_ti_char SUBROUTINE ext_int_put_var_ti_char ( DataHandle,Element, Varname, Data, Status ) USE module_ext_internal IMPLICIT NONE - INCLUDE 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: Element CHARACTER*(*) :: VarName @@ -1313,7 +1315,7 @@ SUBROUTINE ext_int_put_var_ti_char ( DataHandle,Element, Varname, Data, Status IF ( int_valid_handle (DataHandle) ) THEN IF ( int_handle_in_use( DataHandle ) ) THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), int_var_ti_char ) + DataHandle, TRIM(Element), TRIM(VarName), TRIM(Data), INT_VAR_TI_CHAR ) WRITE( unit=DataHandle ) hdrbuf ENDIF ENDIF @@ -1465,7 +1467,7 @@ SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldTy USE module_ext_internal IMPLICIT NONE #include "wrf_io_flags.h" - include 'intio_tags.h' + INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStr CHARACTER*(*) :: VarName @@ -1519,7 +1521,7 @@ SUBROUTINE ext_int_read_field ( DataHandle , DateStr , VarName , Field , FieldTy READ( unit=DataHandle, iostat=istat ) hdrbuf ! this is okay as long as no other record type has data that follows IF ( istat .EQ. 0 ) THEN code = hdrbuf(2) - IF ( code .EQ. int_field ) THEN + IF ( code .EQ. INT_FIELD ) THEN CALL int_get_write_field_header ( hdrbuf, hdrbufsize, inttypesize, typesize, & locDataHandle , locDateStr , locVarName , Field , locFieldType , locComm , locIOComm, & locDomainDesc , locMemoryOrder , locStagger , locDimNames , & diff --git a/external/io_int/io_int_idx.c b/external/io_int/io_int_idx.c index 8f812dd356..772263359e 100644 --- a/external/io_int/io_int_idx.c +++ b/external/io_int/io_int_idx.c @@ -19,7 +19,7 @@ #include #include "io_int_idx.h" -#include "io_int_idx_tags.h" +#include "intio_tags.h" /* Static/Private functions within this file */ diff --git a/external/io_int/makefile b/external/io_int/makefile index 3033670e32..e52b7c7bef 100644 --- a/external/io_int/makefile +++ b/external/io_int/makefile @@ -32,11 +32,8 @@ io_int.f: io_int.F90 module_internal_header_util.o io_int.o: io_int.f ../../inc/intio_tags.h $(FC) $(FCFLAGS) -I../../inc -I../ioapi_share -o $@ -c $*.f -io_int_idx_tags.h: ../../inc/intio_tags.h - awk '{print "#define", toupper($$4), $$6}' < ../../inc/intio_tags.h > $@ - -io_int_idx.o: io_int_idx.c io_int_idx.h io_int_idx_tags.h - $(CC) -o $@ -c $(CFLAGS_LOCAL) $*.c +io_int_idx.o: io_int_idx.c io_int_idx.h + $(CC) -I../../inc -o $@ -c $(CFLAGS_LOCAL) $*.c module_io_int_idx.o: module_io_int_idx.f $(FC) $(FCFLAGS) -o $@ -c $*.f @@ -91,5 +88,5 @@ test_io_mpi: test_io_mpi.f90 $(LIB) $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $@.f90 -L. -lwrfio_int superclean: - @$(RM) *.f *.o *.obj *.i *.mod $(LIB) diffwrf io_int_idx_tags.h \ - test_io_idx test_io_mpi io_int_idx_tags.h + @$(RM) *.f *.o *.obj *.i *.mod $(LIB) diffwrf \ + test_io_idx test_io_mpi diff --git a/external/io_netcdf/CMakeLists.txt b/external/io_netcdf/CMakeLists.txt new file mode 100644 index 0000000000..ac93792869 --- /dev/null +++ b/external/io_netcdf/CMakeLists.txt @@ -0,0 +1,113 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +# Do this first to simplify steps later +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( + ${FOLDER_COMPILE_TARGET} + PUBLIC + $<$:$> + $<$:$> + ${netCDF_LIBRARIES} + ${netCDF-Fortran_LIBRARIES} + ) + +# Because of the way netCDF provides its info and the way cmake auto-gens RPATH, we need to help it along +target_link_directories( + ${FOLDER_COMPILE_TARGET} + PUBLIC + ${netCDF_LIBRARY_DIR} + ${netCDF-Fortran_LIBRARY_DIR} + ) + +target_include_directories( + ${FOLDER_COMPILE_TARGET} + PUBLIC + $ + $ + $ + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + + +# First preprocess +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +get_target_property ( FOLDER_COMPILE_TARGET_INCLUDES ${FOLDER_COMPILE_TARGET} INCLUDE_DIRECTORIES ) +wrf_c_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + INCLUDES ${FOLDER_COMPILE_TARGET_INCLUDES} + DEFINITIONS ${DIR_DEFS} + SOURCES wrf_io.F90 + ) + +# Now M4 preprocess +wrf_m4_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + PREFIX "m4_preproc_" + EXTENSION ".f90" + SOURCES ${CMAKE_CURRENT_BINARY_DIR}/preproc/wrf_io.f90 + DEPENDENCIES ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + TARGET_SCOPE ${FOLDER_COMPILE_TARGET} + FLAGS ${M4_FLAGS} + ) + +add_dependencies( ${FOLDER_COMPILE_TARGET} ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + ${CMAKE_CURRENT_BINARY_DIR}/preproc/m4_preproc_wrf_io.f90 + module_wrfsi_static.F90 + field_routines.F90 + ) + +# Now build diffwrf +set( DIFFWRF_TARGET diffwrf_nc ) +add_executable( + ${DIFFWRF_TARGET} + diffwrf.F90 + ${PROJECT_SOURCE_DIR}/frame/clog.c + ${PROJECT_SOURCE_DIR}/frame/module_wrf_error.F + ${PROJECT_SOURCE_DIR}/frame/wrf_debug.F + ) + +target_link_libraries( + ${DIFFWRF_TARGET} + PRIVATE + ${FOLDER_COMPILE_TARGET} + ) +set_target_properties( + ${DIFFWRF_TARGET} + PROPERTIES + # Just dump everything in here + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/modules/${DIFFWRF_TARGET} + Fortran_FORMAT FREE + ) + + +install( + TARGETS ${FOLDER_COMPILE_TARGET} ${DIFFWRF_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_netcdf/wrf_io.F90 b/external/io_netcdf/wrf_io.F90 index ec2162d2d5..8863e4e29f 100644 --- a/external/io_netcdf/wrf_io.F90 +++ b/external/io_netcdf/wrf_io.F90 @@ -754,7 +754,7 @@ subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) - +! Cannot use following define due to gfortran cpp traditional mode concatenation limitations !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) @@ -940,7 +940,7 @@ subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) - +! Cannot use following define due to gfortran cpp traditional mode concatenation limitations !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) diff --git a/external/io_netcdfpar/CMakeLists.txt b/external/io_netcdfpar/CMakeLists.txt new file mode 100644 index 0000000000..8a0db9b9c9 --- /dev/null +++ b/external/io_netcdfpar/CMakeLists.txt @@ -0,0 +1,113 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +# Do this first to simplify steps later +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( + ${FOLDER_COMPILE_TARGET} + PUBLIC + $<$:$> + $<$:$> + ${netCDF_LIBRARIES} + ${netCDF-Fortran_LIBRARIES} + ) + +# Because of the way netCDF provides its info and the way cmake auto-gens RPATH, we need to help it along +target_link_directories( + ${FOLDER_COMPILE_TARGET} + PUBLIC + ${netCDF_LIBRARY_DIR} + ${netCDF-Fortran_LIBRARY_DIR} + ) + +target_include_directories( + ${FOLDER_COMPILE_TARGET} + PUBLIC + $ + $ + $ + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + + +# First preprocess +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +get_target_property ( FOLDER_COMPILE_TARGET_INCLUDES ${FOLDER_COMPILE_TARGET} INCLUDE_DIRECTORIES ) +wrf_c_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + INCLUDES ${FOLDER_COMPILE_TARGET_INCLUDES} + DEFINITIONS ${DIR_DEFS} + SOURCES wrf_io.F90 + ) + +# Now M4 preprocess +wrf_m4_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + PREFIX "m4_preproc_" + EXTENSION ".f90" + SOURCES ${CMAKE_CURRENT_BINARY_DIR}/preproc/wrf_io.f90 + DEPENDENCIES ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + TARGET_SCOPE ${FOLDER_COMPILE_TARGET} + FLAGS ${M4_FLAGS} + ) + +add_dependencies( ${FOLDER_COMPILE_TARGET} ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + ${CMAKE_CURRENT_BINARY_DIR}/preproc/m4_preproc_wrf_io.f90 + module_wrfsi_static.F90 + field_routines.F90 + ) + +# Now build diffwrf +set( DIFFWRF_TARGET diffwrf_ncpar ) +add_executable( + ${DIFFWRF_TARGET} + diffwrf.F90 + ${PROJECT_SOURCE_DIR}/frame/clog.c + ${PROJECT_SOURCE_DIR}/frame/module_wrf_error.F + ${PROJECT_SOURCE_DIR}/frame/wrf_debug.F + ) + +target_link_libraries( + ${DIFFWRF_TARGET} + PRIVATE + ${FOLDER_COMPILE_TARGET} + ) +set_target_properties( + ${DIFFWRF_TARGET} + PROPERTIES + # Just dump everything in here + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/modules/${DIFFWRF_TARGET} + Fortran_FORMAT FREE + ) + + +install( + TARGETS ${FOLDER_COMPILE_TARGET} ${DIFFWRF_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_netcdfpar/wrf_io.F90 b/external/io_netcdfpar/wrf_io.F90 index a76ec5d82d..86e25dd2cb 100644 --- a/external/io_netcdfpar/wrf_io.F90 +++ b/external/io_netcdfpar/wrf_io.F90 @@ -767,7 +767,7 @@ subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) - +! Cannot use following define due to gfortran cpp traditional mode concatenation limitations !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) @@ -953,7 +953,7 @@ subroutine TransposeToR4a(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) - +! Cannot use following define due to gfortran cpp traditional mode concatenation limitations !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) diff --git a/external/io_phdf5/CMakeLists.txt b/external/io_phdf5/CMakeLists.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/external/io_pio/CMakeLists.txt b/external/io_pio/CMakeLists.txt new file mode 100644 index 0000000000..130b8921d3 --- /dev/null +++ b/external/io_pio/CMakeLists.txt @@ -0,0 +1,49 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + wrf_data_pio.F90 + pio_routines.F90 + wrf_io.F90 + field_routines.F90 + read_bdy_routines.F90 + module_wrfsi_static.F90 + ) + + +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) diff --git a/external/io_pnetcdf/CMakeLists.txt b/external/io_pnetcdf/CMakeLists.txt new file mode 100644 index 0000000000..1717f71383 --- /dev/null +++ b/external/io_pnetcdf/CMakeLists.txt @@ -0,0 +1,78 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) + +add_library( + ${FOLDER_COMPILE_TARGET} + STATIC + ) + +# Do this first to simplify steps later +set_target_properties( + ${FOLDER_COMPILE_TARGET} + PROPERTIES + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + EXPORT_PROPERTIES Fortran_MODULE_DIRECTORY + ) + + +target_link_libraries( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_LIBRARIES} + ${pnetCDF_LIBRARIES} + $<$:$> + $<$:$> + ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${pnetCDF_INCLUDE_DIRS} + ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_SOURCE_DIR}/../ioapi_share + ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} + ) + + +# First preprocess +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +get_target_property ( FOLDER_COMPILE_TARGET_INCLUDES ${FOLDER_COMPILE_TARGET} INCLUDE_DIRECTORIES ) +wrf_c_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + INCLUDES ${FOLDER_COMPILE_TARGET_INCLUDES} + DEFINITIONS ${DIR_DEFS} + SOURCES wrf_io.F90 + ) + +# Now M4 preprocess +wrf_m4_preproc_fortran( + TARGET_NAME ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + PREFIX "m4_preproc_" + EXTENSION ".f90" + SOURCES ${CMAKE_CURRENT_BINARY_DIR}/preproc/wrf_io.f90 + DEPENDENCIES ${FOLDER_COMPILE_TARGET}_c_preproc_wrf_io + TARGET_SCOPE ${FOLDER_COMPILE_TARGET} + FLAGS ${M4_FLAGS} + ) + +add_dependencies( ${FOLDER_COMPILE_TARGET} ${FOLDER_COMPILE_TARGET}_m4_preproc_wrf_io ) + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + ${CMAKE_CURRENT_BINARY_DIR}/preproc/m4_preproc_wrf_io.f90 + module_wrfsi_static.F90 + field_routines.F90 + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + EXPORT ${EXPORT_NAME}Targets + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) + diff --git a/external/io_pnetcdf/wrf_io.F90 b/external/io_pnetcdf/wrf_io.F90 index 18f6ac078a..9d9c3733b4 100644 --- a/external/io_pnetcdf/wrf_io.F90 +++ b/external/io_pnetcdf/wrf_io.F90 @@ -740,7 +740,7 @@ subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) - +! Cannot use following define due to gfortran cpp traditional mode concatenation limitations !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1)) ! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1)))) diff --git a/external/ioapi_share/CMakeLists.txt b/external/ioapi_share/CMakeLists.txt new file mode 100644 index 0000000000..ddd37ecae2 --- /dev/null +++ b/external/ioapi_share/CMakeLists.txt @@ -0,0 +1,11 @@ +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) +set( + WRF_INCLUDE_FILES + wrf_io_flags.h + wrf_status_codes.h + ) + +install( + FILES ${WRF_INCLUDE_FILES} + DESTINATION include/external/${FOLDER_COMPILE_TARGET} + ) \ No newline at end of file diff --git a/external/ioapi_share/wrf_status_codes.h b/external/ioapi_share/wrf_status_codes.h index 98484da413..8dfb44b53e 100644 --- a/external/ioapi_share/wrf_status_codes.h +++ b/external/ioapi_share/wrf_status_codes.h @@ -132,3 +132,12 @@ integer, parameter :: WRF_HDF5_ERR_OTHERS = -320 integer, parameter :: WRF_HDF5_ERR_ATTRIBUTE_OTHERS = -321 + integer, parameter :: WRF_GRIB2_ERR_GRIBCREATE = -401 + integer, parameter :: WRF_GRIB2_ERR_ADDLOCAL = -402 + integer, parameter :: WRF_GRIB2_ERR_ADDGRIB = -403 + integer, parameter :: WRF_GRIB2_ERR_ADDFIELD = -404 + integer, parameter :: WRF_GRIB2_ERR_GRIBEND = -405 + integer, parameter :: WRF_GRIB2_ERR_WRITE = -406 + integer, parameter :: WRF_GRIB2_ERR_GRIB2MAP = -407 + integer, parameter :: WRF_GRIB2_ERR_GETGB2 = -408 + integer, parameter :: WRF_GRIB2_ERR_READ = -409 diff --git a/frame/CMakeLists.txt b/frame/CMakeLists.txt new file mode 100644 index 0000000000..59f8d2551b --- /dev/null +++ b/frame/CMakeLists.txt @@ -0,0 +1,169 @@ +# WRF CMake Build + +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) +set( + WRF_INCLUDE_FILES + module_internal_header_util.F + ${CMAKE_BINARY_DIR}/frame/module_state_description.F + ) + + +######################################################################################################################## +# Extra stuff for things that depend on registry code +# https://stackoverflow.com/a/50640971 +# Generate all the combinations dynamically, not a fan of this file breakdown +######################################################################################################################## +set( nl_dyn_source ) +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +foreach( n RANGE 0 7 ) + + wrf_c_preproc_fortran( + TARGET_NAME nl_set_${n} + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + PREFIX "nl_set_${n}_" + INCLUDES ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_BINARY_DIR}/inc + DEPENDENCIES registry_code + DEFINITIONS ${DIR_DEFS} NNN=${n} NL_set_ROUTINES + SOURCES nl_access_routines.F + ) + wrf_c_preproc_fortran( + TARGET_NAME nl_get_${n} + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + PREFIX "nl_get_${n}_" + INCLUDES ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_BINARY_DIR}/inc + DEPENDENCIES registry_code + DEFINITIONS ${DIR_DEFS} NNN=${n} NL_get_ROUTINES + SOURCES nl_access_routines.F + ) + + add_dependencies( ${PROJECT_NAME}_Core nl_get_${n} nl_set_${n} ) + + list( + APPEND + nl_dyn_source + ${CMAKE_CURRENT_BINARY_DIR}/preproc/nl_set_${n}_nl_access_routines.f90 + ${CMAKE_CURRENT_BINARY_DIR}/preproc/nl_get_${n}_nl_access_routines.f90 + ) + +endforeach() + +if ( ${USE_M4} ) + wrf_m4_preproc_fortran( + TARGET_NAME md_calls + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".inc" + SOURCES md_calls.m4 + TARGET_SCOPE ${PROJECT_NAME}_Core + FLAGS ${M4_FLAGS} + ) + +else() + # Copy from arch quickly + # Normally I would say we just add it as source but it is an include file and I don't want to potentially + # pollute the include chain by adding in arch/ *and* I want to maintain the order of operations + # for target dependencies + wrf_copy_source_files( + TARGET_NAME md_calls + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + SOURCES ${PROJECT_SOURCE_DIR}/arch/md_calls.inc + ) +endif() + +add_dependencies( ${PROJECT_NAME}_Core md_calls ) +target_include_directories( + ${PROJECT_NAME}_Core + PRIVATE + ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + ) +######################################################################################################################## +# +# Now define base framework +# +######################################################################################################################## +set( MODULE_DM module_dm_stubs.F ) +if ( ${USE_RSL_LITE} ) + message( STATUS "Setting module_dm to RSL_LITE" ) + set( MODULE_DM ${PROJECT_SOURCE_DIR}/external/RSL_LITE/module_dm.F ) +endif() + +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + ${WRF_INCLUDE_FILES} + + module_configure.F + module_driver_constants.F + module_domain_type.F + module_domain.F + module_streams.F + module_wrf_error.F + module_machine.F + module_timing.F + # module_dm.F + ${MODULE_DM} + module_cpl.F + module_cpl_oasis3.F + + + module_alloc_space_0.F + module_alloc_space_1.F + module_alloc_space_2.F + module_alloc_space_3.F + module_alloc_space_4.F + module_alloc_space_5.F + module_alloc_space_6.F + module_alloc_space_7.F + module_alloc_space_8.F + module_alloc_space_9.F + + ${CMAKE_BINARY_DIR}/frame/module_state_description.F # GENERATED + ${nl_dyn_source} # GENERATED + + clog.c + collect_on_comm.c + hires_timer.c + libmassv.F + + module_clear_halos.F + module_comm_dm.F + module_comm_dm_0.F + module_comm_dm_1.F + module_comm_dm_2.F + module_comm_dm_3.F + module_comm_dm_4.F + module_comm_nesting_dm.F + + + + module_integrate.F + + module_io.F + module_io_quilt.F + + module_nesting.F + module_quilt_outbuf_ops.F + module_sm.F + module_tiles.F + + pack_utils.c + wrf_debug.F + wrf_num_bytes_between.c + wrf_shutdown.F + ) + +# Disable optimizations on these files always +set_source_files_properties( + ${nl_dyn_source} + PROPERTIES + COMPILE_FLAGS + $<$:${WRF_FCNOOPT}> + ) + +install( + FILES ${WRF_INCLUDE_FILES} + DESTINATION include/${FOLDER_COMPILE_TARGET} + ) \ No newline at end of file diff --git a/frame/module_configure.F b/frame/module_configure.F index 4e0ae808c3..8554a7d92a 100644 --- a/frame/module_configure.F +++ b/frame/module_configure.F @@ -15,7 +15,8 @@ SUBROUTINE init_module_scalar_tables END SUBROUTINE init_module_scalar_tables END MODULE module_scalar_tables -#if( WRF_CHEM == 1 && WRF_KPP == 1 ) +#ifdef WRF_CHEM +#ifdef WRF_KPP MODULE module_irr_diag INTEGER, parameter :: max_eqn = 1200 @@ -45,6 +46,7 @@ END SUBROUTINE init_module_irr_diag END MODULE module_irr_diag #endif +#endif MODULE module_configure diff --git a/frame/module_domain_type.F b/frame/module_domain_type.F index bafe99d4ed..e04b4f0231 100644 --- a/frame/module_domain_type.F +++ b/frame/module_domain_type.F @@ -224,14 +224,14 @@ MODULE module_domain_type Type(WRFU_TimeInterval) :: last_dtInterval ! Time series location information - INTEGER :: ntsloc, ntsloc_domain - INTEGER :: next_ts_time - INTEGER, POINTER, DIMENSION(:) :: itsloc, jtsloc, id_tsloc - REAL, POINTER, DIMENSION(:) :: lattsloc, lontsloc - CHARACTER (LEN=5), POINTER, DIMENSION(:) :: nametsloc - CHARACTER (LEN=25), POINTER, DIMENSION(:) :: desctsloc - CHARACTER (LEN=256), POINTER, DIMENSION(:) :: ts_filename - LOGICAL :: have_calculated_tslocs + INTEGER :: ntsloc = 0, ntsloc_domain = 0 + INTEGER :: next_ts_time = 0 + INTEGER, POINTER, DIMENSION(:) :: itsloc => NULL(), jtsloc => NULL(), id_tsloc => NULL() + REAL, POINTER, DIMENSION(:) :: lattsloc => NULL(), lontsloc => NULL() + CHARACTER (LEN=5), POINTER, DIMENSION(:) :: nametsloc => NULL() + CHARACTER (LEN=25), POINTER, DIMENSION(:) :: desctsloc => NULL() + CHARACTER (LEN=256), POINTER, DIMENSION(:) :: ts_filename => NULL() + LOGICAL :: have_calculated_tslocs = .FALSE. LOGICAL :: have_displayed_alloc_stats ! used in module_alloc_space to display alloc stats; only do it once. ! Track location information diff --git a/frame/module_driver_constants.F b/frame/module_driver_constants.F index c8a36cf0e6..6c7d797d1a 100644 --- a/frame/module_driver_constants.F +++ b/frame/module_driver_constants.F @@ -85,9 +85,9 @@ MODULE module_driver_constants ! The maximum number of obs indexes (for conventional DA obs) #if (WRF_CHEM == 1) - INTEGER , PARAMETER :: num_ob_indexes = 30 + INTEGER , PARAMETER :: num_ob_indexes = 31 #else - INTEGER , PARAMETER :: num_ob_indexes = 29 + INTEGER , PARAMETER :: num_ob_indexes = 30 #endif diff --git a/frame/module_internal_header_util.F b/frame/module_internal_header_util.F index bfff25916a..35ad9d92b6 100644 --- a/frame/module_internal_header_util.F +++ b/frame/module_internal_header_util.F @@ -110,7 +110,7 @@ SUBROUTINE int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For a "write field" header it must be set to -! int_field. See file intio_tags.h for a complete list of +! INT_FIELD. See file intio_tags.h for a complete list of ! these tags. ! ftypesize: Size of field data type in bytes. ! DataHandle: Descriptor for an open data set. @@ -145,7 +145,7 @@ SUBROUTINE int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize hdrbuf(1) = 0 ! deferred -- this will be length of header - hdrbuf(2) = int_field + hdrbuf(2) = INT_FIELD hdrbuf(3) = ftypesize i = 4 @@ -215,8 +215,8 @@ SUBROUTINE int_get_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize INTEGER i, n hdrbufsize = hdrbuf(1) - IF ( hdrbuf(2) .NE. int_field ) THEN - write(mess,*)'int_get_write_field_header: hdrbuf(2) ne int_field ',hdrbuf(2),int_field + IF ( hdrbuf(2) .NE. INT_FIELD ) THEN + write(mess,*)'int_get_write_field_header: hdrbuf(2) ne INT_FIELD ',hdrbuf(2),INT_FIELD CALL wrf_error_fatal ( mess ) ENDIF ftypesize = hdrbuf(3) @@ -269,7 +269,7 @@ SUBROUTINE int_gen_ofr_header( hdrbuf, hdrbufsize, itypesize, & ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "open for read" header it must be set to -! int_open_for_read. See file intio_tags.h for a complete list of +! INT_OPEN_FOR_READ. See file intio_tags.h for a complete list of ! these tags. ! DataHandle: Descriptor for an open data set. ! FileName: File name. @@ -292,7 +292,7 @@ SUBROUTINE int_gen_ofr_header( hdrbuf, hdrbufsize, itypesize, & INTEGER i, n, i1 ! hdrbuf(1) = 0 !deferred - hdrbuf(2) = int_open_for_read + hdrbuf(2) = INT_OPEN_FOR_READ i = 3 hdrbuf(i) = DataHandle ; i = i+1 @@ -324,8 +324,8 @@ SUBROUTINE int_get_ofr_header( hdrbuf, hdrbufsize, itypesize, & INTEGER i, n ! hdrbufsize = hdrbuf(1) -! IF ( hdrbuf(2) .NE. int_open_for_read ) THEN -! CALL wrf_error_fatal ( "int_get_ofr_header: hdrbuf ne int_open_for_read") +! IF ( hdrbuf(2) .NE. INT_OPEN_FOR_READ ) THEN +! CALL wrf_error_fatal ( "int_get_ofr_header: hdrbuf ne INT_OPEN_FOR_READ") ! ENDIF i = 3 DataHandle = hdrbuf(i) ; i = i+1 @@ -356,7 +356,7 @@ SUBROUTINE int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "open for write begin" header it must be set to -! int_open_for_write_begin. See file intio_tags.h for a complete list of +! INT_OPEN_FOR_WRITE_BEGIN. See file intio_tags.h for a complete list of ! these tags. ! DataHandle: Descriptor for an open data set. ! io_form: I/O format for this file (netCDF, etc.). @@ -381,7 +381,7 @@ SUBROUTINE int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & INTEGER i, n, j ! hdrbuf(1) = 0 !deferred - hdrbuf(2) = int_open_for_write_begin + hdrbuf(2) = INT_OPEN_FOR_WRITE_BEGIN i = 3 hdrbuf(i) = DataHandle ; i = i+1 hdrbuf(i) = io_form ; i = i+1 @@ -420,8 +420,8 @@ SUBROUTINE int_get_ofwb_header( hdrbuf, hdrbufsize, itypesize, & ! hdrbufsize = hdrbuf(1) !write(0,*)' int_get_ofwb_header next rec start ',hdrbuf(hdrbufsize+1) -! IF ( hdrbuf(2) .NE. int_open_for_write_begin ) THEN -! CALL wrf_error_fatal ( "int_get_ofwb_header: hdrbuf ne int_open_for_write_begin") +! IF ( hdrbuf(2) .NE. INT_OPEN_FOR_WRITE_BEGIN ) THEN +! CALL wrf_error_fatal ( "int_get_ofwb_header: hdrbuf ne INT_OPEN_FOR_WRITE_BEGIN") ! ENDIF i = 3 DataHandle = hdrbuf(i) ; i = i+1 @@ -529,7 +529,7 @@ SUBROUTINE int_gen_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, & ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "time-independent integer" header it must be -! set to int_dom_ti_integer. See file intio_tags.h for a complete +! set to INT_DOM_TI_INTEGER. See file intio_tags.h for a complete ! list of these tags. ! DataHandle: Descriptor for an open data set. ! typesize: Size in bytes of each element of Data. @@ -584,7 +584,7 @@ SUBROUTINE int_gen_ti_header_integer_varna( hdrbuf, hdrbufsize, itypesize, types ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "time-independent integer" header it must be -! set to int_dom_ti_integer. See file intio_tags.h for a complete +! set to INT_DOM_TI_INTEGER. See file intio_tags.h for a complete ! list of these tags. ! DataHandle: Descriptor for an open data set. ! typesize: Size in bytes of each element of Data. @@ -761,7 +761,7 @@ SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "time-independent string" header it must be -! set to int_dom_ti_char. See file intio_tags.h for a complete +! set to INT_DOM_TI_CHAR. See file intio_tags.h for a complete ! list of these tags. ! DataHandle: Descriptor for an open data set. ! typesize: 1 (size in bytes of a single CHARACTER). @@ -852,7 +852,7 @@ SUBROUTINE int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize, & ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "time-dependent string" header it must be -! set to int_dom_td_char. See file intio_tags.h for a complete +! set to INT_DOM_TD_CHAR. See file intio_tags.h for a complete ! list of these tags. ! DataHandle: Descriptor for an open data set. ! typesize: 1 (size in bytes of a single CHARACTER). @@ -937,7 +937,7 @@ SUBROUTINE int_gen_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, & ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "time-dependent integer" header it must be -! set to int_dom_td_integer. See file intio_tags.h for a complete +! set to INT_DOM_TD_INTEGER. See file intio_tags.h for a complete ! list of these tags. ! DataHandle: Descriptor for an open data set. ! typesize: 1 (size in bytes of a single CHARACTER). @@ -1074,7 +1074,7 @@ SUBROUTINE int_gen_noop_header ( hdrbuf, hdrbufsize, itypesize ) ! hdrbufsize: Size of this data header in bytes. ! headerTag: "Header tag" that tells the I/O quilt servers what kind of ! header this is. For an "no-operation" header it must be -! set to int_noop. See file intio_tags.h for a complete +! set to INT_NOOP. See file intio_tags.h for a complete ! list of these tags. ! ! @@ -1087,7 +1087,7 @@ SUBROUTINE int_gen_noop_header ( hdrbuf, hdrbufsize, itypesize ) INTEGER i ! hdrbuf(1) = 0 !deferred - hdrbuf(2) = int_noop + hdrbuf(2) = INT_NOOP i = 3 hdrbufsize = (i-1) * itypesize ! return the number in bytes hdrbuf(1) = hdrbufsize @@ -1110,8 +1110,8 @@ SUBROUTINE int_get_noop_header( hdrbuf, hdrbufsize, itypesize ) INTEGER i ! hdrbufsize = hdrbuf(1) - IF ( hdrbuf(2) .NE. int_noop ) THEN - CALL wrf_error_fatal ( "int_get_noop_header: hdrbuf ne int_noop") + IF ( hdrbuf(2) .NE. INT_NOOP ) THEN + CALL wrf_error_fatal ( "int_get_noop_header: hdrbuf ne INT_NOOP") ENDIF i = 3 RETURN diff --git a/frame/module_io_quilt_old.F b/frame/module_io_quilt_old.F index e46d8b1095..69e443a69b 100644 --- a/frame/module_io_quilt_old.F +++ b/frame/module_io_quilt_old.F @@ -743,7 +743,7 @@ SUBROUTINE quilt ALLOCATE( obuf( 4096 ) ) ! DataHandle is provided as second element of reduced CALL int_gen_handle_header( obuf, obufsize, itypesize, & - reduced(2) , int_ioclose ) + reduced(2) , INT_IOCLOSE ) if(poll_servers) then ! Once we're done closing, we need to tell the master @@ -775,7 +775,7 @@ SUBROUTINE quilt DO WHILE ( icurs .lt. obufsize ) ! { hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) SELECT CASE ( hdr_tag ) - CASE ( int_field ) + CASE ( INT_FIELD ) CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & DomainDesc , MemoryOrder , Stagger , DimNames , & @@ -806,7 +806,7 @@ SUBROUTINE quilt call add_to_bufsize_for_field( VarName, chunksize ) icurs = icurs + chunksize ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks + CASE ( INT_OPEN_FOR_WRITE_COMMIT ) ! only one per group of tasks hdrbufsize = obuf(icurs/itypesize) IF (num_commit_messages.EQ.0) THEN call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) @@ -851,14 +851,14 @@ SUBROUTINE quilt ! call to collect_on_comm: 1 bona fide output record from server task ! 0 and noops from the rest. - IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & - .OR.hdr_tag.NE.int_noop) THEN + IF ((hdr_tag.EQ.INT_NOOP.AND.mytask_local.NE.0.AND.num_noops.LE.0) & + .OR.hdr_tag.NE.INT_NOOP) THEN write(VarName,'(I5.5)')vid !write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) call add_to_bufsize_for_field( VarName, hdrbufsize ) vid = vid+1 ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + IF ( hdr_tag .EQ. INT_NOOP ) num_noops = num_noops + 1 icurs = icurs + hdrbufsize END SELECT ENDDO ! } @@ -874,7 +874,7 @@ SUBROUTINE quilt !write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) SELECT CASE ( hdr_tag ) - CASE ( int_field ) + CASE ( INT_FIELD ) CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & DomainDesc , MemoryOrder , Stagger , DimNames , & @@ -902,7 +902,7 @@ SUBROUTINE quilt call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) icurs = icurs + chunksize ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks + CASE ( INT_OPEN_FOR_WRITE_COMMIT ) ! only one per group of tasks hdrbufsize = obuf(icurs/itypesize) IF (num_commit_messages.EQ.0) THEN call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) @@ -911,14 +911,14 @@ SUBROUTINE quilt icurs = icurs + hdrbufsize CASE DEFAULT hdrbufsize = obuf(icurs/itypesize) - IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & - .OR.hdr_tag.NE.int_noop) THEN + IF ((hdr_tag.EQ.INT_NOOP.AND.mytask_local.NE.0.AND.num_noops.LE.0) & + .OR.hdr_tag.NE.INT_NOOP) THEN write(VarName,'(I5.5)')vid !write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) vid = vid+1 ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + IF ( hdr_tag .EQ. INT_NOOP ) num_noops = num_noops + 1 icurs = icurs + hdrbufsize END SELECT ENDDO !} @@ -981,12 +981,12 @@ SUBROUTINE quilt ! actually quite easy. "Noop" requests exist to help avoid race conditions. ! In some cases, only one compute task will everything about a request so ! other compute tasks send "noop" requests. - CASE ( int_noop ) + CASE ( INT_NOOP ) CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize ) icurs = icurs + hdrbufsize ! The I/O server "root" handles the "put_dom_td_real" request. - CASE ( int_dom_td_real ) + CASE ( INT_DOM_TD_REAL ) CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & @@ -1020,8 +1020,8 @@ SUBROUTINE quilt DEALLOCATE( RData ) ! The I/O server "root" handles the "put_dom_ti_real" request. - CASE ( int_dom_ti_real ) -!write(0,*)' int_dom_ti_real ' + CASE ( INT_DOM_TI_REAL ) +!write(0,*)' INT_DOM_TI_REAL ' CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & @@ -1057,8 +1057,8 @@ SUBROUTINE quilt DEALLOCATE( RData ) ! The I/O server "root" handles the "put_dom_td_integer" request. - CASE ( int_dom_td_integer ) -!write(0,*)' int_dom_td_integer ' + CASE ( INT_DOM_TD_INTEGER ) +!write(0,*)' INT_DOM_TD_INTEGER ' CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & @@ -1093,8 +1093,8 @@ SUBROUTINE quilt DEALLOCATE( IData ) ! The I/O server "root" handles the "put_dom_ti_integer" request. - CASE ( int_dom_ti_integer ) -!write(0,*)' int_dom_ti_integer ' + CASE ( INT_DOM_TI_INTEGER ) +!write(0,*)' INT_DOM_TI_INTEGER ' CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c @@ -1131,8 +1131,8 @@ SUBROUTINE quilt DEALLOCATE( IData) ! The I/O server "root" handles the "set_time" request. - CASE ( int_set_time ) -!write(0,*)' int_set_time ' + CASE ( INT_SET_TIME ) +!write(0,*)' INT_SET_TIME ' CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle, Element, VarName, CData, code ) SELECT CASE (use_package(io_form(DataHandle))) @@ -1147,7 +1147,7 @@ SUBROUTINE quilt icurs = icurs + hdrbufsize ! The I/O server "root" handles the "put_dom_ti_char" request. - CASE ( int_dom_ti_char ) + CASE ( INT_DOM_TI_CHAR ) !write(0,*)' before int_get_ti_header_char ' CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle, Element, VarName, CData, code ) @@ -1181,8 +1181,8 @@ SUBROUTINE quilt icurs = icurs + hdrbufsize ! The I/O server "root" handles the "put_var_ti_char" request. - CASE ( int_var_ti_char ) -!write(0,*)' int_var_ti_char ' + CASE ( INT_VAR_TI_CHAR ) +!write(0,*)' INT_VAR_TI_CHAR ' CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle, Element, VarName, CData, code ) @@ -1213,12 +1213,12 @@ SUBROUTINE quilt icurs = icurs + hdrbufsize - CASE ( int_ioexit ) + CASE ( INT_IOEXIT ) ! ioexit is now handled by sending negative message length to server CALL wrf_error_fatal( & - "quilt: should have handled int_ioexit already") + "quilt: should have handled INT_IOEXIT already") ! The I/O server "root" handles the "ioclose" request. - CASE ( int_ioclose ) + CASE ( INT_IOCLOSE ) CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle , code ) icurs = icurs + hdrbufsize @@ -1281,17 +1281,17 @@ SUBROUTINE quilt ENDIF ! The I/O server "root" handles the "open_for_write_begin" request. - CASE ( int_open_for_write_begin ) + CASE ( INT_OPEN_FOR_WRITE_BEGIN ) CALL int_get_ofwb_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & FileName,SysDepInfo,io_form_arg,DataHandle ) -!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize -!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize -!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle -!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN itypesize ',itypesize,' itypesize ',itypesize +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN icurs ', icurs, hdrbufsize +!JMDEBUGwrite(0,*)' INT_OPEN_FOR_WRITE_BEGIN FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN SysDepInfo ',TRIM(SysDepInfo) icurs = icurs + hdrbufsize -!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) io_form(DataHandle) = io_form_arg @@ -1327,14 +1327,14 @@ SUBROUTINE quilt ! In this case, the "okay_to_commit" is simply set to .true. so "write_field" ! requests will initiate writes to disk. Actual commit will be done after ! all requests in this batch have been handled. - CASE ( int_open_for_write_commit ) + CASE ( INT_OPEN_FOR_WRITE_COMMIT ) CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle , code ) icurs = icurs + hdrbufsize okay_to_commit(DataHandle) = .true. -! The I/O server "root" handles the "write_field" (int_field) request. +! The I/O server "root" handles the "write_field" (INT_FIELD) request. ! If okay_to_write(DataHandle) is .true. then the patch in the ! header (bigbuf) is written to a globally-sized internal output buffer via ! the call to store_patch_in_outbuf(). Note that this is where the actual @@ -1342,9 +1342,9 @@ SUBROUTINE quilt ! okay_to_write(DataHandle) is .false. then external I/O package interfaces ! are called to write metadata for I/O formats that support native metadata. ! -! NOTE that the I/O server "root" will only see write_field (int_field) +! NOTE that the I/O server "root" will only see write_field (INT_FIELD) ! requests AFTER an "iosync" request. - CASE ( int_field ) + CASE ( INT_FIELD ) CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & @@ -1352,7 +1352,7 @@ SUBROUTINE quilt DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & PatchStart , PatchEnd ) -!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) +!write(0,*)' INT_FIELD ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) icurs = icurs + hdrbufsize IF ( okay_to_write(DataHandle) ) THEN @@ -1418,7 +1418,7 @@ SUBROUTINE quilt Status = 0 END SELECT ENDIF - CASE ( int_iosync ) + CASE ( INT_IOSYNC ) CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle , code ) icurs = icurs + hdrbufsize @@ -1436,7 +1436,7 @@ SUBROUTINE quilt ! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write ! them to disk now. ! NOTE that the I/O server "root" will only have called -! store_patch_in_outbuf() when handling write_field (int_field) +! store_patch_in_outbuf() when handling write_field (INT_FIELD) ! commands which only arrive AFTER an "iosync" command. ! CALL start_timing CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle))) @@ -1745,7 +1745,7 @@ SUBROUTINE quilt_pnc ALLOCATE( obuf( 4096 ) ) ! DataHandle is provided as second element of reduced CALL int_gen_handle_header( obuf, obufsize, itypesize, & - reduced(2) , int_ioclose ) + reduced(2) , INT_IOCLOSE ) ENDIF !write(0,*)'calling init_store_piece_of_field' @@ -1772,7 +1772,7 @@ SUBROUTINE quilt_pnc DO WHILE ( icurs .lt. obufsize ) ! { hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) SELECT CASE ( hdr_tag ) - CASE ( int_field ) + CASE ( INT_FIELD ) CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & DomainDesc , MemoryOrder , Stagger , DimNames , & @@ -1803,7 +1803,7 @@ SUBROUTINE quilt_pnc call add_to_bufsize_for_field( VarName, chunksize ) icurs = icurs + chunksize ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks + CASE ( INT_OPEN_FOR_WRITE_COMMIT ) ! only one per group of tasks hdrbufsize = obuf(icurs/itypesize) IF (num_commit_messages.EQ.0) THEN call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) @@ -1841,13 +1841,13 @@ SUBROUTINE quilt_pnc ! 5. Logic below does not allow any noop records through since each IO ! server task now receives a valid record (from the 'compute-group master' ! when doing replicated output - IF (hdr_tag.NE.int_noop) THEN + IF (hdr_tag.NE.INT_NOOP) THEN write(VarName,'(I5.5)')vid !write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) call add_to_bufsize_for_field( VarName, hdrbufsize ) vid = vid+1 ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + IF ( hdr_tag .EQ. INT_NOOP ) num_noops = num_noops + 1 icurs = icurs + hdrbufsize END SELECT @@ -1864,7 +1864,7 @@ SUBROUTINE quilt_pnc !write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) SELECT CASE ( hdr_tag ) - CASE ( int_field ) + CASE ( INT_FIELD ) CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & DomainDesc , MemoryOrder , Stagger , DimNames , & @@ -1892,7 +1892,7 @@ SUBROUTINE quilt_pnc icurs = icurs + chunksize !write(0,*) 'A-1a',TRIM(VarName),' icurs ',icurs,PatchStart(1:3),PatchEnd(1:3) ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks + CASE ( INT_OPEN_FOR_WRITE_COMMIT ) ! only one per group of tasks hdrbufsize = obuf(icurs/itypesize) IF (num_commit_messages.EQ.0) THEN call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) @@ -1901,14 +1901,14 @@ SUBROUTINE quilt_pnc icurs = icurs + hdrbufsize CASE DEFAULT hdrbufsize = obuf(icurs/itypesize) - IF (hdr_tag.NE.int_noop) THEN + IF (hdr_tag.NE.INT_NOOP) THEN write(VarName,'(I5.5)')vid !write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) vid = vid+1 ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + IF ( hdr_tag .EQ. INT_NOOP ) num_noops = num_noops + 1 icurs = icurs + hdrbufsize END SELECT ENDDO !} while(icurs < obufsize) @@ -1942,13 +1942,13 @@ SUBROUTINE quilt_pnc SELECT CASE ( get_hdr_tag( obuf(icurs/itypesize) ) ) ! The I/O server handles the "noop" (do nothing) request. This is ! actually quite easy. "Noop" requests exist to help avoid race conditions. - CASE ( int_noop ) + CASE ( INT_NOOP ) CALL int_get_noop_header( obuf(icurs/itypesize), & hdrbufsize, itypesize ) icurs = icurs + hdrbufsize ! The I/O server "root" handles the "put_dom_td_real" request. - CASE ( int_dom_td_real ) + CASE ( INT_DOM_TD_REAL ) CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & @@ -1986,7 +1986,7 @@ SUBROUTINE quilt_pnc DEALLOCATE( RData ) ! Every I/O server handles the "put_dom_ti_real" request. - CASE ( int_dom_ti_real ) + CASE ( INT_DOM_TI_REAL ) CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c @@ -2026,7 +2026,7 @@ SUBROUTINE quilt_pnc DEALLOCATE( RData ) ! Every I/O server handles the "put_dom_td_integer" request. - CASE ( int_dom_td_integer ) + CASE ( INT_DOM_TD_INTEGER ) CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c @@ -2066,7 +2066,7 @@ SUBROUTINE quilt_pnc DEALLOCATE( IData ) ! Every I/O server handles the "put_dom_ti_integer" request. - CASE ( int_dom_ti_integer ) + CASE ( INT_DOM_TI_INTEGER ) CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c @@ -2106,7 +2106,7 @@ SUBROUTINE quilt_pnc DEALLOCATE( IData) ! Every I/O server handles the "set_time" request. - CASE ( int_set_time ) + CASE ( INT_SET_TIME ) CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle, Element, VarName, CData, code ) @@ -2122,7 +2122,7 @@ SUBROUTINE quilt_pnc icurs = icurs + hdrbufsize ! Every I/O server handles the "put_dom_ti_char" request. - CASE ( int_dom_ti_char ) + CASE ( INT_DOM_TI_CHAR ) CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle, Element, VarName, CData, code ) @@ -2159,7 +2159,7 @@ SUBROUTINE quilt_pnc icurs = icurs + hdrbufsize ! Every I/O server handles the "put_var_ti_char" request. - CASE ( int_var_ti_char ) + CASE ( INT_VAR_TI_CHAR ) CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle, Element, VarName, CData, code ) @@ -2195,12 +2195,12 @@ SUBROUTINE quilt_pnc icurs = icurs + hdrbufsize - CASE ( int_ioexit ) + CASE ( INT_IOEXIT ) ! ioexit is now handled by sending negative message length to server CALL wrf_error_fatal( & - "quilt: should have handled int_ioexit already") + "quilt: should have handled INT_IOEXIT already") ! Every I/O server handles the "ioclose" request. - CASE ( int_ioclose ) + CASE ( INT_IOCLOSE ) CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle , code ) icurs = icurs + hdrbufsize @@ -2256,17 +2256,17 @@ SUBROUTINE quilt_pnc ENDIF ! Every I/O server handles the "open_for_write_begin" request. - CASE ( int_open_for_write_begin ) + CASE ( INT_OPEN_FOR_WRITE_BEGIN ) CALL int_get_ofwb_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & FileName,SysDepInfo,io_form_arg,DataHandle ) -!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize -!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize -!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle -!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN itypesize ',itypesize,' itypesize ',itypesize +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN icurs ', icurs, hdrbufsize +!JMDEBUGwrite(0,*)' INT_OPEN_FOR_WRITE_BEGIN FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN SysDepInfo ',TRIM(SysDepInfo) icurs = icurs + hdrbufsize -!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) +!write(0,*)' INT_OPEN_FOR_WRITE_BEGIN new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) io_form(DataHandle) = io_form_arg @@ -2304,25 +2304,25 @@ SUBROUTINE quilt_pnc ! Every I/O server handles the "open_for_write_commit" request. ! In this case, the "okay_to_commit" is simply set to .true. so "write_field" -! (int_field) requests will initiate writes to disk. Actual commit will be done after +! (INT_FIELD) requests will initiate writes to disk. Actual commit will be done after ! all requests in this batch have been handled. - CASE ( int_open_for_write_commit ) + CASE ( INT_OPEN_FOR_WRITE_COMMIT ) CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle , code ) icurs = icurs + hdrbufsize okay_to_commit(DataHandle) = .true. -! Every I/O server handles the "write_field" (int_field) request. +! Every I/O server handles the "write_field" (INT_FIELD) request. ! If okay_to_write(DataHandle) is .true. then the patch in the ! header (bigbuf) is written to disk using pNetCDF. Note that this is where the actual ! "quilting" (reassembly of patches onto a full-size domain) is done. If ! okay_to_write(DataHandle) is .false. then external I/O package interfaces ! are called to write metadata for I/O formats that support native metadata. ! -! NOTE that the I/O servers will only see write_field (int_field) +! NOTE that the I/O servers will only see write_field (INT_FIELD) ! requests AFTER an "iosync" request. - CASE ( int_field ) + CASE ( INT_FIELD ) CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & @@ -2330,7 +2330,7 @@ SUBROUTINE quilt_pnc DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & PatchStart , PatchEnd ) -!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) +!write(0,*)' INT_FIELD ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) icurs = icurs + hdrbufsize IF ( okay_to_write(DataHandle) ) THEN @@ -2445,7 +2445,7 @@ SUBROUTINE quilt_pnc Status = 0 END SELECT ENDIF - CASE ( int_iosync ) + CASE ( INT_IOSYNC ) CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & DataHandle , code ) icurs = icurs + hdrbufsize @@ -2465,7 +2465,7 @@ SUBROUTINE quilt_pnc ! (via a call to store_patch_in_outbuf_pnc()) then call write_outbuf_pnc() ! to write them to disk now. ! NOTE that the I/O server will only have called -! store_patch_in_outbuf() when handling write_field (int_field) +! store_patch_in_outbuf() when handling write_field (INT_FIELD) ! commands which only arrive AFTER an "iosync" command. ! CALL start_timing #ifdef PNETCDF_QUILT @@ -3088,7 +3088,7 @@ SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status ) !ARP parallel IO IF(compute_group_master(1)) THEN CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_open_for_write_commit ) + DataHandle, INT_OPEN_FOR_WRITE_COMMIT ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) END IF @@ -3096,7 +3096,7 @@ SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status ) IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_open_for_write_commit ) + DataHandle, INT_OPEN_FOR_WRITE_COMMIT ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3336,14 +3336,14 @@ SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status ) #ifdef PNETCDF_QUILT IF ( compute_group_master(1) )THEN CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_ioclose ) + DataHandle, INT_IOCLOSE ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF #else IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle , int_ioclose ) + DataHandle , INT_IOCLOSE ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3420,7 +3420,7 @@ SUBROUTINE wrf_quilt_ioexit( Status ) !ARP Send the ioexit message just once to each IOServer when using parallel IO IF( compute_group_master(1) ) THEN CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_ioexit ) + DataHandle, INT_IOEXIT ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) END IF @@ -3428,7 +3428,7 @@ SUBROUTINE wrf_quilt_ioexit( Status ) IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle , int_ioexit ) ! Handle is dummy + DataHandle , INT_IOEXIT ) ! Handle is dummy ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3532,14 +3532,14 @@ SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status ) ! can't tell that's what they are on the IO servers themselves - therefore use ! the compute_group_master process. CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, "TIMESTAMP", "", Data, int_set_time ) + DataHandle, "TIMESTAMP", "", Data, INT_SET_TIME ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) END IF #else IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, "TIMESTAMP", "", Data, int_set_time ) + DataHandle, "TIMESTAMP", "", Data, INT_SET_TIME ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3648,14 +3648,14 @@ SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Statu #ifdef PNETCDF_QUILT IF ( compute_group_master(1) ) THEN CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle, locElement, Data, Count, int_dom_ti_real ) + DataHandle, locElement, Data, Count, INT_DOM_TI_REAL ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF #else IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle, locElement, Data, Count, int_dom_ti_real ) + DataHandle, locElement, Data, Count, INT_DOM_TI_REAL ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3806,7 +3806,7 @@ SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, St IF ( compute_group_master(1) )THEN CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & DataHandle, locElement, Data, Count, & - int_dom_ti_integer ) + INT_DOM_TI_INTEGER ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3814,7 +3814,7 @@ SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, St IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & DataHandle, locElement, Data, Count, & - int_dom_ti_integer ) + INT_DOM_TI_INTEGER ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -3966,14 +3966,14 @@ SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status ) IF(compute_group_master(1))THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & DataHandle, Element, "", Data, & - int_dom_ti_char ) + INT_DOM_TI_CHAR ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) END IF #else IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, Element, "", Data, int_dom_ti_char ) + DataHandle, Element, "", Data, INT_DOM_TI_CHAR ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -4510,7 +4510,7 @@ SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Stat IF ( compute_group_master(1) ) THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & DataHandle, TRIM(Element), & - TRIM(VarName), TRIM(Data), int_var_ti_char ) + TRIM(VarName), TRIM(Data), INT_VAR_TI_CHAR ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -4518,7 +4518,7 @@ SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Stat IF ( wrf_dm_on_monitor() ) THEN CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & DataHandle, TRIM(Element), & - TRIM(VarName), TRIM(Data), int_var_ti_char ) + TRIM(VarName), TRIM(Data), INT_VAR_TI_CHAR ) ELSE CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) ENDIF @@ -4852,7 +4852,7 @@ SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , Fiel ! During a "real" write, this routine begins by allocating ! int_local_output_buffer if it has not already been allocated. Sizes ! accumulated during "training" are used to determine how big -! int_local_output_buffer must be. This routine then stores "int_field" +! int_local_output_buffer must be. This routine then stores "INT_FIELD" ! headers and associated field data in int_local_output_buffer. The contents ! of int_local_output_buffer are actually sent to the I/O quilt server in ! routine wrf_quilt_iosync(). This scheme allows output of multiple variables diff --git a/frame/pack_utils.c b/frame/pack_utils.c index d7669ccfd5..bdd608d3e1 100644 --- a/frame/pack_utils.c +++ b/frame/pack_utils.c @@ -59,6 +59,7 @@ /* CALL int_pack_data ( hdrbuf , hdrbufsiz * inttypesize , int_local_output_buffer, int_local_output_cursor ) */ +void INT_PACK_DATA ( unsigned char *buf , int *ninbytes , unsigned char *obuf, int *cursor ) { int i, lcurs ; @@ -372,7 +373,7 @@ void *malloc(size_t size) # endif # if !defined(MS_SUA) && !defined(_WIN32) # include -RSL_INTERNAL_MICROCLOCK () +int RSL_INTERNAL_MICROCLOCK () { struct timeval tb ; struct timezone tzp ; diff --git a/hydro/CMakeLists.txt b/hydro/CMakeLists.txt new file mode 100644 index 0000000000..ee756e71ac --- /dev/null +++ b/hydro/CMakeLists.txt @@ -0,0 +1,93 @@ +# additions that WRF-Hydro's top CMakeLists.txt handles +set(CMAKE_Fortran_MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/hydro/mods) +add_definitions(-DMPP_LAND) +if (WRF_HYDRO_NUDGING STREQUAL "1") + add_definitions(-DWRF_HYDRO_NUDGING=1) +endif() + +# build the various sup-projects +add_subdirectory("MPP") +add_subdirectory("utils") +add_subdirectory("IO") +add_subdirectory("OrchestratorLayer") +add_subdirectory("Debug_Utilities") +add_subdirectory("Routing/Overland") +add_subdirectory("Routing/Subsurface") +add_subdirectory("Routing/Reservoirs") +add_subdirectory("Data_Rec") +add_subdirectory("Routing") +add_subdirectory("HYDRO_drv") +add_subdirectory("CPL/WRF_cpl") + +if (WRF_HYDRO_NUDGING STREQUAL "1") + add_subdirectory("nudging") + add_dependencies(hydro_routing hydro_nudging) + add_dependencies(hydro_driver hydro_nudging) +endif() + +# add module dependencies +add_dependencies(hydro_debug_utils hydro_mpp) +add_dependencies(hydro_utils hydro_mpp) +add_dependencies(hydro_orchestrator hydro_netcdf_layer) + +add_dependencies(hydro_routing + hydro_mpp + hydro_routing_overland + hydro_routing_subsurface + hydro_routing_reservoirs + hydro_routing_reservoirs_levelpool + hydro_routing_reservoirs_hybrid + hydro_utils +) + +add_dependencies(hydro_routing_reservoirs_hybrid hydro_routing_reservoirs_levelpool) +add_dependencies(hydro_routing_overland hydro_mpp) + +# currently unused Routing/Groundwater directory +# add_subdirectory("Routing/Groundwater") +# add_dependencies(hydro_routing +# hydro_routing_groundwater +# hydro_routing_groundwater_bucket +# hydro_routing_groundwater_nhd +# hydro_routing_groundwater_simple +# ) +# add_dependencies(hydro_routing_groundwater hydro_mpp) +# add_dependencies(hydro_routing_groundwater_bucket hydro_routing_groundwater) +# add_dependencies(hydro_routing_groundwater_simple +# hydro_routing_groundwater +# hydro_routing_groundwater_bucket +# ) +# add_dependencies(hydro_routing_groundwater_nhd +# hydro_routing_groundwater +# hydro_routing_groundwater_bucket +# ) + +add_dependencies(hydro_driver + hydro_routing + hydro_debug_utils +) + +add_dependencies(hydro_data_rec + hydro_routing_overland + hydro_routing_subsurface + hydro_routing_reservoirs +) + +add_library(wrfhydro INTERFACE) +target_link_libraries(wrfhydro INTERFACE + hydro_utils + hydro_mpp + hydro_debug_utils + hydro_routing_overland + hydro_routing_subsurface + hydro_data_rec + hydro_routing + hydro_routing_reservoirs_levelpool + hydro_routing_reservoirs_hybrid + hydro_routing_reservoirs_rfc + hydro_routing_reservoirs + hydro_wrf_cpl + hydro_orchestrator + hydro_netcdf_layer + hydro_driver +) diff --git a/hydro/CPL/WRF_cpl/CMakeLists.txt b/hydro/CPL/WRF_cpl/CMakeLists.txt new file mode 100644 index 0000000000..914191ba5b --- /dev/null +++ b/hydro/CPL/WRF_cpl/CMakeLists.txt @@ -0,0 +1,25 @@ +add_library(hydro_wrf_cpl STATIC + wrf_drv_HYDRO.F90 + module_wrf_HYDRO.F90 +) + +add_dependencies(hydro_wrf_cpl + hydro_mpp + hydro_utils + hydro_debug_utils + hydro_data_rec + hydro_driver + hydro_orchestrator + ${PROJECT_NAME}_Core + MPI::MPI_Fortran +) + +target_include_directories(hydro_wrf_cpl + PRIVATE + $ + $ +) + +target_include_directories(hydro_wrf_cpl PUBLIC + ${MPI_Fortran_MODULE_DIR} +) diff --git a/hydro/CPL/WRF_cpl/Makefile b/hydro/CPL/WRF_cpl/Makefile index fa196ae9df..eb5a9599ce 100644 --- a/hydro/CPL/WRF_cpl/Makefile +++ b/hydro/CPL/WRF_cpl/Makefile @@ -1,7 +1,7 @@ # Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 @@ -15,9 +15,9 @@ OBJS = \ wrf_drv_HYDRO.o all: $(OBJS) -.F.o: +.F90.o: @echo "" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).F90 @echo "" ar -r ../../lib/libHYDRO.a $(@) diff --git a/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F b/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 similarity index 94% rename from hydro/CPL/WRF_cpl/module_wrf_HYDRO.F rename to hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 index 9c88bfc4b7..e6882f74eb 100644 --- a/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F +++ b/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 @@ -3,20 +3,20 @@ ! Abstract: ! History Log: ! -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: module module_WRF_HYDRO @@ -39,10 +39,10 @@ module module_WRF_HYDRO USE module_configure, ONLY : grid_config_rec_type !yw USE module_configure, only : config_flags USE module_configure, only: model_config_rec - + implicit none - + !yw added for check soil moisture and soiltype integer :: checkSOIL_flag @@ -50,7 +50,7 @@ module module_WRF_HYDRO character(len=19) :: cpl_outdate #endif ! -! added to consider the adaptive time step from WRF model. +! added to consider the adaptive time step from WRF model. real :: dtrt_ter0 , dtrt_ch0 integer :: mm0 @@ -59,7 +59,7 @@ module module_WRF_HYDRO CONTAINS -!wrf_cpl_HYDRO will not call the off-line lsm +!wrf_cpl_HYDRO will not call the off-line lsm !ywGW subroutine wrf_cpl_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte) subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) @@ -77,7 +77,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) integer ntime integer :: i,j - + integer :: ierr !output flux and state variable @@ -95,16 +95,16 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) ntime = 1 - + nlst(did)%dt = HYDRO_dt - + if(.not. RT_DOMAIN(did)%initialized) then !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels nlst(did)%nsoil = grid%num_soil_layers - + #ifdef MPP_LAND call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) call MPP_LAND_INIT(grid%e_we - grid%s_we - 1, grid%e_sn - grid%s_sn - 1) @@ -131,8 +131,8 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) write(6,*) "sf_surface_physics is ", grid%sf_surface_physics #endif - if(grid%sf_surface_physics .eq. 5) then - ! clm4 + if(grid%sf_surface_physics .eq. 5) then + ! clm4 call HYDRO_ini(ntime,did=did,ix0=1,jx0=1) else call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte)) @@ -159,7 +159,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) mm0 = mm endif - dtrt_ter0 = nlst(did)%dtrt_ter + dtrt_ter0 = nlst(did)%dtrt_ter if(nlst(did)%dtrt_ch .ge. HYDRO_dt) then nlst(did)%dtrt_ch = HYDRO_dt @@ -170,7 +170,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) mm0 = mm endif - dtrt_ch0 = nlst(did)%dtrt_ch + dtrt_ch0 = nlst(did)%dtrt_ch endif if((mm0*nlst(did)%dtrt_ter) .ne. HYDRO_dt) then ! WRF model time step changed. @@ -195,7 +195,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) endif endif -#ifdef HYDRO_D +#ifdef HYDRO_D write(6,*) "mm, nlst(did)%dt = ",mm, nlst(did)%dt #endif @@ -204,7 +204,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) nn = nlst(did)%nsoil - ! get the data from WRF + ! get the data from WRF @@ -217,10 +217,10 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) - end do + end do rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) - endif + endif call HYDRO_exe(did) @@ -230,7 +230,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k) grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k) grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k) - end do + end do ! update WRF variable after running routing model. grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%overland%control%surface_water_head_lsm @@ -257,7 +257,7 @@ end subroutine wrf_cpl_HYDRO subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) ! input: z1,v1,kk1,z,ix,jx,kk ! output: vout -! interpolate based on soil layer: z1 and z +! interpolate based on soil layer: z1 and z ! z : soil layer of output variable. ! z1: array of soil layers of input variable. implicit none @@ -265,7 +265,7 @@ subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) integer:: kk1, ix,jx,kk, vegtyp(ix,jx) real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) - + do j = 1, jx do i = 1, ix do k = 1, kk @@ -279,7 +279,7 @@ end subroutine wrf2lsm subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) ! input: z1,v1,kk1,z,ix,jx,kk ! output: vout -! interpolate based on soil layer: z1 and z +! interpolate based on soil layer: z1 and z ! z : soil layer of output variable. ! z1: array of soil layers of input variable. implicit none @@ -287,7 +287,7 @@ subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) integer:: kk1, ix,jx,kk, vegtyp(ix,jx) real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) - + do j = 1, jx do i = 1, ix do k = 1, kk @@ -310,11 +310,11 @@ subroutine interpLayer(inZ,inV,inK,outZ,outV) outV = inV(1)*w1-inV(2)*w2 return elseif(outZ .ge. inZ(inK)) then - w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) + w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) outV = inV(inK)*w1 -inV(inK-1)* w2 return - else + else do k = 2, inK if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then k1 = k-1 @@ -322,8 +322,8 @@ subroutine interpLayer(inZ,inV,inK,outZ,outV) w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) outV = inV(k2)*w1 + inV(k1)*w2 - return - end if + return + end if end do endif end subroutine interpLayer @@ -364,7 +364,7 @@ subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) close(71) #else - open(13, form="formatted") + open(13, form="formatted") !read OV_ROUGH first read(13,*) nn read(13,*) @@ -407,7 +407,7 @@ subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) end subroutine lsm_wrf_input - subroutine checkSoil(did) + subroutine checkSoil(did) implicit none integer :: did where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 diff --git a/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F b/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 similarity index 96% rename from hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F rename to hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 index 299870068b..4dceba6af5 100644 --- a/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F +++ b/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 @@ -3,20 +3,20 @@ ! Abstract: ! History Log: ! -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: module module_WRF_HYDRO @@ -34,13 +34,13 @@ module module_WRF_HYDRO USE module_domain, ONLY : domain, domain_clock_get implicit none - + !yw added for check soil moisture and soiltype integer :: checkSOIL_flag ! -! added to consider the adaptive time step from WRF model. - real :: dtrt0 +! added to consider the adaptive time step from WRF model. + real :: dtrt0 integer :: mm0, itime @@ -48,7 +48,7 @@ module module_WRF_HYDRO CONTAINS -!wrf_cpl_HYDRO_finescale will not call the off-line lsm +!wrf_cpl_HYDRO_finescale will not call the off-line lsm subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte) use module_NoahMP_hrldas_driver, only: noah_timestep , land_driver_ini implicit none @@ -64,7 +64,7 @@ subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte) integer ntime integer :: i,j - + !output flux and state variable @@ -79,10 +79,10 @@ subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte) ntime = 1 - + nlst(did)%dt = HYDRO_dt - itime = itime + 1 + itime = itime + 1 if(.not. RT_DOMAIN(did)%initialized) then itime = 1 @@ -124,7 +124,7 @@ subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte) mm0 = mm endif - dtrt0 = nlst(did)%dtrt + dtrt0 = nlst(did)%dtrt endif if((mm0*nlst(did)%dtrt) .ne. HYDRO_dt) then ! WRF model time step changed. @@ -138,7 +138,7 @@ subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte) endif endif -#ifdef HYDRO_D +#ifdef HYDRO_D write(6,*) "mm, nlst(did)%dt = ",mm, nlst(did)%dt #endif @@ -158,7 +158,7 @@ subroutine wrf2l_finemesh(,its,ite,jts,jte, T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL emiss0, albedo0 ) use module_NoahMP_hrldas_driver, only: P8W, T_PHY, U_PHY, V_PHY, QV_CURR, RAINBL_tmp, LAI, VEGFRA, finemesh,finemesh_factor, & emiss,albedo - + implicit none real, domain(:,:),INTENT(IN) :: T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0, & emiss0, albedo0, TSK0,HFX0, QFX0,LH0,GRDFLX0,SMSTAV0,SMSTOT0,SFCRUNOFF0, UDRUNOFF0, SNOWC0, SMOIS0, SH2O0, & @@ -247,10 +247,10 @@ subroutine wrf2finegrid(wrfGrid,fineGrid,ix,jx,AGGFACTRT) real, dimension(:,:), intent(out)::fineGrid integer:: i,j,ii,jj,ix,jx, AGGFACTRT do j = 1, jx - do i = 1, ix + do i = 1, ix do ii =AGGFACTRT-1,0,-1 do jj =AGGFACTRT-1,0,-1 - IXXRT=I*AGGFACTRT-ii + IXXRT=I*AGGFACTRT-ii JYYRT=J*AGGFACTRT-jj fineGrid(ixxrt,jyyrt) = wrfGrid(i,j) enddo @@ -265,11 +265,11 @@ subroutine finegrid2wrf(fineGrid,wrfGrid,ix,jx,AGGFACTRT) real, dimension(:,:), intent(in)::fineGrid integer:: i,j,ii,jj,ix,jx, AGGFACTRT do j = 1, jx - do i = 1, ix + do i = 1, ix wrfGrid(k,j) = 0.0 do ii =AGGFACTRT-1,0,-1 do jj =AGGFACTRT-1,0,-1 - IXXRT=I*AGGFACTRT-ii + IXXRT=I*AGGFACTRT-ii JYYRT=J*AGGFACTRT-jj wrfGrid(i,j) = wrfGrid(i,j) + fineGrid(ixxrt,jyyrt) enddo @@ -286,7 +286,7 @@ end subroutine finegrid2wrf subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) ! input: z1,v1,kk1,z,ix,jx,kk ! output: vout -! interpolate based on soil layer: z1 and z +! interpolate based on soil layer: z1 and z ! z : soil layer of output variable. ! z1: array of soil layers of input variable. implicit none @@ -294,7 +294,7 @@ subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) integer:: kk1, ix,jx,kk, vegtyp(ix,jx) real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) - + do j = 1, jx do i = 1, ix do k = 1, kk @@ -308,7 +308,7 @@ end subroutine wrf2lsm subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) ! input: z1,v1,kk1,z,ix,jx,kk ! output: vout -! interpolate based on soil layer: z1 and z +! interpolate based on soil layer: z1 and z ! z : soil layer of output variable. ! z1: array of soil layers of input variable. implicit none @@ -316,7 +316,7 @@ subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) integer:: kk1, ix,jx,kk, vegtyp(ix,jx) real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) - + do j = 1, jx do i = 1, ix do k = 1, kk @@ -339,11 +339,11 @@ subroutine interpLayer(inZ,inV,inK,outZ,outV) outV = inV(1)*w1-inV(2)*w2 return elseif(outZ .ge. inZ(inK)) then - w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) + w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) outV = inV(inK)*w1 -inV(inK-1)* w2 return - else + else do k = 2, inK if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then k1 = k-1 @@ -351,8 +351,8 @@ subroutine interpLayer(inZ,inV,inK,outZ,outV) w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) outV = inV(k2)*w1 + inV(k1)*w2 - return - end if + return + end if end do endif end subroutine interpLayer diff --git a/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F b/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 similarity index 93% rename from hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F rename to hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 index f8cc01e40d..db86a573e7 100644 --- a/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F +++ b/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 @@ -3,27 +3,27 @@ ! Abstract: ! History Log: ! -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: !2345678 !ywGW subroutine wrf_drv_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte) subroutine wrf_drv_HYDRO(HYDRO_dt,grid, its,ite,jts,jte) use module_wrf_HYDRO, only: wrf_cpl_HYDRO - USE module_domain, ONLY : domain + USE module_domain, ONLY : domain USE module_configure, ONLY : grid_config_rec_type implicit none integer:: its,ite,jts,jte @@ -36,7 +36,7 @@ subroutine wrf_drv_HYDRO(HYDRO_dt,grid, its,ite,jts,jte) if(grid%num_nests .lt. 1) then !ywGW call wrf_cpl_HYDRO(HYDRO_dt, grid, config_flags, its,ite,jts,jte) - call wrf_cpl_HYDRO(HYDRO_dt, grid, its,ite,jts,jte) + call wrf_cpl_HYDRO(HYDRO_dt, grid, its,ite,jts,jte) endif end subroutine wrf_drv_HYDRO @@ -50,8 +50,7 @@ subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte) TYPE ( domain ), INTENT(INOUT) :: grid if(grid%num_nests .lt. 1) then -! call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte) +! call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte) endif end subroutine wrf_drv_HYDRO_ini - diff --git a/hydro/Data_Rec/CMakeLists.txt b/hydro/Data_Rec/CMakeLists.txt new file mode 100644 index 0000000000..7590bd19f2 --- /dev/null +++ b/hydro/Data_Rec/CMakeLists.txt @@ -0,0 +1,7 @@ +add_library(hydro_data_rec STATIC + module_gw_gw2d_data.F90 + module_rt_inc.F90 + module_namelist_inc.F90 + module_RT_data.F90 + module_namelist.F90 +) diff --git a/hydro/Data_Rec/Makefile b/hydro/Data_Rec/Makefile index 2de17518d3..263b5a4d99 100644 --- a/hydro/Data_Rec/Makefile +++ b/hydro/Data_Rec/Makefile @@ -1,26 +1,30 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros OBJS = \ + module_namelist_inc.o \ module_namelist.o \ + module_rt_inc.o \ module_RT_data.o \ module_gw_gw2d_data.o -all: $(OBJS) +all: $(OBJS) -.F.o: +.F90.o: @echo "" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I../mod $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I../mod $(*).F90 @echo "" ar -r ../lib/libHYDRO.a $(@) cp *.mod ../mod # Dependencies: # +module_namelist.o: module_namelist_inc.o +module_RT_data.o: module_rt_inc.o clean: rm -f *.o *.mod *.stb *~ diff --git a/hydro/Data_Rec/module_RT_data.F b/hydro/Data_Rec/module_RT_data.F deleted file mode 100644 index a1fa61b4de..0000000000 --- a/hydro/Data_Rec/module_RT_data.F +++ /dev/null @@ -1,37 +0,0 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - -Module module_RT_data - use overland_data - use module_subsurface_data - use module_subsurface_static_data - use module_subsurface_input - use module_subsurface_output - use module_reservoir, only: reservoir_container - use iso_fortran_env, only: int64 - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -! define Routing data -#include "rt_include.inc" - TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN - save RT_DOMAIN - integer :: cur_did -end module module_RT_data diff --git a/hydro/Data_Rec/module_gw_gw2d_data.F b/hydro/Data_Rec/module_RT_data.F90 similarity index 69% rename from hydro/Data_Rec/module_gw_gw2d_data.F rename to hydro/Data_Rec/module_RT_data.F90 index 20792b7c39..01a608d46c 100644 --- a/hydro/Data_Rec/module_gw_gw2d_data.F +++ b/hydro/Data_Rec/module_RT_data.F90 @@ -2,29 +2,29 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: -Module module_gw_gw2d_data - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 +Module module_RT_data + use module_rt_inc, only: rt_field + implicit none -#include "gw_field_include.inc" - type (gw_field) :: gw2d(max_domain) - save gw2d - -end module module_gw_gw2d_data + integer, parameter :: max_domain=5 + ! define Routing data + type ( rt_field ), dimension (max_domain) :: RT_DOMAIN + save RT_DOMAIN + integer :: cur_did +end module module_RT_data diff --git a/hydro/Data_Rec/module_gw_gw2d_data.F90 b/hydro/Data_Rec/module_gw_gw2d_data.F90 new file mode 100644 index 0000000000..1784a9950c --- /dev/null +++ b/hydro/Data_Rec/module_gw_gw2d_data.F90 @@ -0,0 +1,60 @@ +! Program Name: +! Author(s)/Contact(s): +! Abstract: +! History Log: +! +! +! Usage: +! Parameters: +! Input Files: +! +! Output Files: +! +! +! Condition codes: +! +! If appropriate, descriptive troubleshooting instructions or +! likely causes for failures could be mentioned here with the +! appropriate error code +! +! User controllable options: + +module module_gw_gw2d_data + implicit none + integer, parameter :: max_domain=5 + + type gw_field + integer :: ix, jx + integer :: allo_status = -99 + + real :: dx, dt + + integer, allocatable, dimension(:,:) :: ltype ! land-sfc type + real, allocatable, dimension(:,:) :: & + elev, & ! elev/bathymetry of sfc rel to sl (m) + bot, & ! elev. aquifer bottom rel to sl (m) + hycond, & ! hydraulic conductivity (m/s per m/m) + poros, & ! porosity (m3/m3) + compres, & ! compressibility (1/Pa) + ho ! head at start of timestep (m) + + real, allocatable, dimension(:,:) :: & + h, & ! head, after ghmcompute (m) + convgw, & ! convergence due to gw flow (m/s) + excess ! surface exceeding groundwater (mm) + + real, allocatable, dimension(:,:) :: & + qdarcyRT, & ! approximated flux between soil and groundwater for coupled simulations on routing grid + qsgwrt, & ! flux between soil and groundwater for coupled simulations on routing grid + qsgw, & ! flux between soil and groundwater for coupled simulations on lsm grid + qgw_chanrt ! flux between groundwater and channel + + real :: ebot, eocn + integer ::istep = 0 + + integer :: its, ite, jts, jte + end type gw_field + + type (gw_field) :: gw2d(max_domain) + save gw2d +end module module_gw_gw2d_data diff --git a/hydro/Data_Rec/module_namelist.F b/hydro/Data_Rec/module_namelist.F90 similarity index 99% rename from hydro/Data_Rec/module_namelist.F rename to hydro/Data_Rec/module_namelist.F90 index 18cf4bfbaf..51303619c7 100644 --- a/hydro/Data_Rec/module_namelist.F +++ b/hydro/Data_Rec/module_namelist.F90 @@ -18,22 +18,20 @@ ! ! User controllable options: -Module module_namelist +module module_namelist #ifdef MPP_LAND USE module_mpp_land #endif use module_hydro_stop, only: HYDRO_stop - - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -#include "namelist.inc" - TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt + use module_namelist_inc, only: namelist_rt_field + implicit none + integer, parameter :: max_domain=5 + type(namelist_rt_field) , dimension(max_domain) :: nlst_rt save nlst_rt -CONTAINS +contains subroutine read_rt_nlst(nlst) implicit none diff --git a/hydro/Data_Rec/module_namelist_inc.F90 b/hydro/Data_Rec/module_namelist_inc.F90 new file mode 100644 index 0000000000..c34b9d768c --- /dev/null +++ b/hydro/Data_Rec/module_namelist_inc.F90 @@ -0,0 +1,98 @@ +module module_namelist_inc + implicit none + type namelist_rt_field + integer :: nsoil, SOLVEG_INITSWC + real,allocatable,dimension(:) :: ZSOIL8 + real*8 :: out_dt, rst_dt + real :: dt !! dt is NOAH_TIMESTEP + integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN + character(len=256) :: restart_file = "" + integer :: split_output_count + integer :: igrid + integer :: rst_bi_in ! used for parallel io with large restart file. + integer :: rst_bi_out ! used for parallel io with large restart file. + ! each process will output the restart tile. + character(len=256) :: geo_static_flnm = "" + character(len=1024) :: land_spatial_meta_flnm = "" + integer :: DEEPGWSPIN + integer :: order_to_write, rst_typ + character(len=256) :: upmap_file = "" ! user defined mapping file for NHDPLUS + character(len=256) :: hydrotbl_f = "" ! hydrotbl file + +! additional character + character :: hgrid + character(len=19) :: olddate="123456" + character(len=19) :: startdate="123456" + character(len=19) :: sincedate="123456" + + integer :: io_config_outputs ! used for NCEP REALTIME OUTPUT + integer :: io_form_outputs ! Flag to turn specify level of internal compression + integer :: t0OutputFlag + integer :: channel_only, channelBucket_only + integer :: output_channelBucket_influx ! used for FORCE_TYPE 9 and 10 + + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT, OVRTSWCRT, AGGFACTRT, & + GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & + sys_cpl, gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, & + gwsoilcpl, UDMP_OPT, bucket_loss, imperv_adj + logical:: GwPreDiag, GwSpinUp + real:: DTRT_TER,DTRT_CH, DTCT, dxrt0, gwChanCondConstIn, gwChanCondConstOut, gwIhShift + character(len=256) :: route_topo_f="" + character(len=256) :: route_chan_f="" + character(len=256) :: route_link_f="" + character(len=256) :: route_lake_f="" + logical :: reservoir_persistence_usgs + logical :: reservoir_persistence_usace + character(len=256) :: reservoir_parameter_file="" + character(len=256) :: reservoir_usgs_timeslice_path="" + character(len=256) :: reservoir_usace_timeslice_path="" + integer :: reservoir_observation_lookback_hours + integer :: reservoir_observation_update_time_interval_seconds + logical :: reservoir_rfc_forecasts + character(len=256) :: reservoir_rfc_forecasts_time_series_path="" + integer :: reservoir_rfc_forecasts_lookback_hours + logical :: reservoir_type_specified + character(len=256) :: route_direction_f="" + character(len=256) :: route_order_f="" + character(len=256) :: gwbasmskfil ="" + character(len=256) :: gwstrmfil ="" + character(len=256) :: geo_finegrid_flnm ="" + character(len=256) :: udmap_file ="" + character(len=256) :: GWBUCKPARM_file = "" + integer :: reservoir_data_ingest ! STUB FOR USE OF REALTIME RESERVOIR DISCHARGE DATA. CURRENTLY NOT IN USE. + character(len=1024) :: reservoir_obs_dir = "" + + logical :: compound_channel + integer ::frxst_pts_out ! ASCII point timeseries output at user specified points + integer ::CHRTOUT_DOMAIN ! Netcdf point timeseries output at all channel points + integer ::CHRTOUT_GRID ! Netcdf grid of channel streamflow values + integer ::CHANOBS_DOMAIN ! NetCDF point timeseries of output at forecast/gage points + integer ::LSMOUT_DOMAIN ! Netcdf grid of variables passed between LSM and routing components + integer ::RTOUT_DOMAIN ! Netcdf grid of terrain routing variables on routing grid + integer ::output_gw ! Netcdf grid of GW + integer ::outlake ! Netcdf grid of lake + integer :: rtFlag + integer ::khour + + logical :: channel_bypass = .FALSE. + +!#ifdef WRF_HYDRO_NUDGING + character(len=256) :: nudgingParamFile + character(len=256) :: netwkReExFile + logical :: readTimesliceParallel + logical :: temporalPersistence + logical :: persistBias + logical :: biasWindowBeforeT0 + character(len=256) :: nudgingLastObsFile + integer :: minNumPairsBiasPersist + integer :: maxAgePairsBiasPersist + logical :: invDistTimeWeightBias + logical :: noConstInterfBias + character(len=256) :: timeSlicePath + integer :: nLastObs +!#endif + + + end type namelist_rt_field +end module module_namelist_inc diff --git a/hydro/Data_Rec/module_rt_inc.F90 b/hydro/Data_Rec/module_rt_inc.F90 new file mode 100644 index 0000000000..f3279c760a --- /dev/null +++ b/hydro/Data_Rec/module_rt_inc.F90 @@ -0,0 +1,270 @@ +module module_rt_inc + use overland_data + use module_subsurface_data + use module_subsurface_static_data + use module_subsurface_input + use module_subsurface_output + use module_reservoir, only: reservoir_container + use iso_fortran_env, only: int64 + implicit none + + TYPE RT_FIELD + type (overland_struct) :: overland + type (subsurface_struct) :: subsurface + type (subsurface_static_interface) :: subsurface_static + type (subsurface_input_interface) :: subsurface_input + type (subsurface_output_interface) :: subsurface_output + + class (reservoir_container), allocatable, dimension(:) :: reservoirs + integer, allocatable, dimension(:) :: reservoir_type ! specifying type of reservoir + integer, allocatable, dimension(:) :: final_reservoir_type ! resolved reservoir type (since it can change) + real, allocatable, dimension(:) :: reservoir_assimilated_value ! observation or forecast assimilated to reservoir discharge + character(len=256), allocatable, dimension(:) :: reservoir_assimilated_source_file ! source file of assimilated value + + INTEGER :: IX, JX + logical :: initialized + logical :: restQSTRM + REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT + !REAL :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT + REAL :: SFHEAD1RT,INFXS1RT,SFHEADRT,ETPND1,INFXSRTOT + !REAL :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC + REAL :: accsuminfxs,diffsuminfxs,RETDEPFRAC + REAL :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT + INTEGER :: IXRT,JXRT,vegct + INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP + INTEGER :: SATLYRCHKRT,DT_FRACRT + INTEGER :: LAKE_CT, STRM_CT + REAL :: RETDEP_CHAN ! Channel retention depth + INTEGER :: NLINKS !maximum number of unique links in channel + INTEGER :: GNLINKS !maximum number of unique links in channel for parallel computation + INTEGER :: NLAKES !number of lakes modeled + INTEGER :: NLINKSL !maximum number of links using linked routing + INTEGER :: MAXORDER !maximum stream order + integer :: timestep_flag ! 1 cold start run else continue run + + INTEGER :: GNLINKSL, linklsS, linklsE , nlinksize !## for reach based channel routing + + INTEGER :: iswater !id for water in vegtyp + INTEGER :: islake !id for lake in vegtyp + INTEGER :: isurban !id for urban in vegtyp + INTEGER :: isoilwater !id for water in soiltyp + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR ROUTING + !INTEGER, allocatable, DIMENSION(:,:) :: CH_NETRT !-- keeps track of the 0-1 channel network ! moved to overland%streams_and_lakes + INTEGER(kind=int64), allocatable, DIMENSION(:,:) :: CH_LNKRT !-- linked routing grid (should combine with CH_NETRT.. redundant Gochis!) + + + INTEGER(kind=int64), allocatable, DIMENSION(:,:) :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links + REAL, allocatable, DIMENSION(:,:) :: LATVAL,LONVAL !-- lat lon + REAL, allocatable, DIMENSION(:,:) :: TERRAIN + REAL, allocatable, DIMENSION(:,:) :: landRunOff ! used for NHDPLUS only + REAL, allocatable, DIMENSION(:) :: CHLAT,CHLON ! channel lat and lon + ! INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, BASIN_MSK,LAK_1K + INTEGER, allocatable, DIMENSION(:,:) :: LAK_1K + INTEGER, allocatable, DIMENSION(:,:) :: g_LAK_1K + ! REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT + !REAL :: QSUBBDRYTRT ! QSUBBDRYTRT moved to subsurface io module + !REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT + REAL, allocatable, DIMENSION(:,:) :: ELRT + !REAL, allocatable, DIMENSION(:,:,:) :: SO8RT + INTEGER, allocatable, DIMENSION(:,:,:) :: SO8LD_D ! SO8RT_D moved to overland properties module + REAL, allocatable, DIMENSION(:,:) :: SO8LD_Vmax + REAL Vmax + !REAL, allocatable, DIMENSION(:,:) :: LKSATRT ! LKSATRT moved to subsurface properties module + !REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT ! SFCHEAD moved to overland control module + REAL, allocatable, DIMENSION(:,:) :: INFXSRT,LKSAT,LKSATRT + !REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC ! SFCHEADSUBRT, INFXSUBRT moved to overland control module + REAL, allocatable, DIMENSION(:,:) :: LKSATFAC + REAL, allocatable, DIMENSION(:,:) :: IMPERVFRAC + !REAL, allocatable, DIMENSION(:,:) :: SOLDEPRT ! QSUBRT, QSUBBDRYRT moved to subsurface io module, SOLDEPRT, ZWATTABLRT move to susurface properties + REAL, allocatable, DIMENSION(:,:) :: SUB_RESID + REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y + INTEGER, allocatable, DIMENSION(:) :: map_l2g, map_g2l + + INTEGER :: nToInd + INTEGER, allocatable, DIMENSION(:) :: toNodeInd + INTEGER(kind=int64), allocatable, DIMENSION(:,:) :: gtoNode + +! temp arrary cwatavail + !real, allocatable, DIMENSION(:,:,:) :: SMCREFRT ! SMCREFRT moved to subsurface grid_transform module +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR GW/Baseflow + INTEGER :: numbasns + INTEGER :: gnumbasns + integer(kind=int64), allocatable, dimension(:) :: basnsInd ! basin index for tile + INTEGER, allocatable, DIMENSION(:,:) :: GWSUBBASMSK !GW basin mask grid + REAL, allocatable, DIMENSION(:,:) :: qinflowbase !strm inflow/baseflow from GW + REAL, allocatable, DIMENSION(:,:) :: SOLDRAIN !time-step drainage + INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk !GW basin mask grid + INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk_lind !GW basin mask grid tile maping index + REAL, allocatable, DIMENSION(:) :: z_gwsubbas !depth in GW bucket + REAL, allocatable, DIMENSION(:) :: qin_gwsubbas !flow to GW bucket + REAL, allocatable, DIMENSION(:) :: qout_gwsubbas!flow from GW bucket + REAL, allocatable, DIMENSION(:) :: qloss_gwsubbas !flow from GW bucket + REAL, allocatable, DIMENSION(:) :: gwbas_pix_ct !ct of strm pixels in + REAL, allocatable, DIMENSION(:) :: basns_area !basin area + REAL, allocatable, DIMENSION(:) :: node_area !nodes area + + REAL, allocatable, DIMENSION(:) :: z_q_bas_parm !GW bucket parameters + INTEGER, allocatable, DIMENSION(:) :: nhdBuckMask !GW bucket mask for NHDPLUS + INTEGER, allocatable, DIMENSION(:) :: ct2_bas !ct of land pixels in basin + REAL, allocatable, DIMENSION(:) :: bas_pcp !sub-basin avg'd pcp + INTEGER :: bas + INTEGER, allocatable, DIMENSION(:) :: bas_id + CHARACTER(len=19) :: header + CHARACTER(len=1) :: jnk + REAL, allocatable, DIMENSION(:) :: gw_buck_coeff !GW bucket model coefficient + REAL, allocatable, DIMENSION(:) :: gw_buck_exp !GW bucket model exponent + REAL, allocatable, DIMENSION(:) :: gw_buck_loss !GW bucket model loss fraction + REAL, allocatable, DIMENSION(:) :: z_max !Height of GW bucket +!DJG Switch for Deep Sat GW Init: + INTEGER :: DEEPGWSPIN !Switch to setup deep GW spinp +!BF Variables for gw2d + integer, allocatable, dimension(:,:) :: soiltyp, soiltypRT + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG,DNY VARIABLES FOR CHANNEL ROUTING +!-- channel params + INTEGER(kind=int64), allocatable, DIMENSION(:) :: LINK !channel link + INTEGER(kind=int64), allocatable, DIMENSION(:) :: TO_NODE !link's to node + INTEGER(kind=int64), allocatable, DIMENSION(:) :: FROM_NODE !link's from node + INTEGER, allocatable, DIMENSION(:) :: ORDER !link's order + INTEGER, allocatable, DIMENSION(:) :: STRMFRXSTPTS !frxst point flag + CHARACTER(len=15), allocatable, DIMENSION(:) :: gages + ! 123456789012345 + CHARACTER(len=15) :: gageMiss = ' ' +! CHARACTER(len=15) :: gageMiss = ' -9999' + + INTEGER, allocatable, DIMENSION(:) :: TYPEL !type of link Muskingum: 0 strm 1 lake + !-- Diffusion: 0 edge or pour; 1 interior; 2 lake + INTEGER, allocatable, DIMENSION(:) :: TYPEN !type of link 0 strm 1 lake + REAL, allocatable, DIMENSION(:) :: QLAKEI !lake inflow in difussion scheme + REAL, allocatable, DIMENSION(:) :: QLAKEO !lake outflow in difussion scheme + INTEGER(kind=int64), allocatable, DIMENSION(:) :: LAKENODE !which nodes flow into which lakes + integer(kind=int64), allocatable, dimension(:) :: LINKID ! id of links on linked routing + REAL, allocatable, DIMENSION(:) :: CVOL ! channel volume + INTEGER(kind=int64), allocatable, DIMENSION(:,:) :: pnode !parent nodes : start from 2 + integer :: maxv_p ! array size for second column of the pnode + + REAL, allocatable, DIMENSION(:) :: MUSK, MUSX !muskingum params + REAL, allocatable, DIMENSION(:) :: CHANLEN !link length + REAL, allocatable, DIMENSION(:) :: MannN !mannings N + REAL, allocatable, DIMENSION(:) :: So !link slope and channel conductivity (m/s) + REAL, allocatable, DIMENSION(:) :: Channk ! channel infiltration parameter + REAL, allocatable, DIMENSION(:) :: ChSSlp ! channel side slope + REAL, allocatable, DIMENSION(:) :: Bw ! Bottom width of channel + REAL, allocatable, DIMENSION(:) :: Tw ! top width of channel + REAL, allocatable, DIMENSION(:) :: Tw_CC ! top width of the (CC) compound channel + REAL, allocatable, DIMENSION(:) :: n_CC ! mannings N of (CC) compound channel + REAL, allocatable, DIMENSION(:,:) :: QLINK !flow in link + integer, allocatable, DIMENSION(:) :: ascendIndex !sorting of routelink +#ifdef WRF_HYDRO_NUDGING + REAL, allocatable, DIMENSION(:) :: nudge !difference between modeled and DA adj link flow +#endif + REAL, allocatable, DIMENSION(:) :: HLINK !head in link + REAL, allocatable, DIMENSION(:) :: ZELEV !elevation of nodes for channel + INTEGER, allocatable, DIMENSION(:) :: CHANXI,CHANYJ !map chan to fine grid + REAL, DIMENSION(50) :: BOTWID,CHANN_K,TOPWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table + REAL, DIMENSION(50) :: TOPWIDCC, NCC !topwidth and mannings n of compund + + ! VARIABLES FOR RESERVOIRS + REAL, allocatable, DIMENSION(:) :: RESHT !reservoir height +!-- lake params + integer(kind=int64), allocatable, dimension(:) :: LAKEIDA !id of lakes in routlink file + integer(kind=int64), allocatable, dimension(:) :: LAKEIDM !id of LAKES Modeled in LAKEPARM.nc or tbl + REAL, allocatable, DIMENSION(:) :: HRZAREA !horizontal extent of lake, km^2 + REAL, allocatable, DIMENSION(:) :: WEIRL !overtop weir length (m) + REAL, allocatable, DIMENSION(:) :: DAML !overtop weir length (m) + REAL, allocatable, DIMENSION(:) :: ORIFICEC !coefficient of orifice + REAL, allocatable, DIMENSION(:) :: ORIFICEA !orifice opening area (m^2) + REAL, allocatable, DIMENSION(:) :: ORIFICEE !orifice elevation (m) + REAL, allocatable, DIMENSION(:) :: LATLAKE, LONLAKE,ELEVLAKE ! lake info + + INTEGER, allocatable, DIMENSION(:) :: LAKEIDX ! integer index for lakes, mapped to linkid + +!!! accumulated variables for reach beased rt + Real*8, allocatable, DIMENSION(:) :: accSfcLatRunoff, accBucket + REAL , allocatable, DIMENSION(:) :: qSfcLatRunoff, qBucket, qBtmVertRunoff + REAL, allocatable, DIMENSION(:) :: accLndRunOff, accQLateral, accStrmvolrt + !REAL, allocatable, DIMENSION(:) :: qqLndRunOff, qqStrmvolrt, qqBucket + REAL, allocatable, DIMENSION(:) :: QLateral, velocity, qloss + +#ifdef MPP_LAND + INTEGER, allocatable, DIMENSION(:) :: lake_index,nlinks_index + INTEGER(kind=int64), allocatable, DIMENSION(:,:) :: Link_location + integer(kind=int64), allocatable, dimension(:) :: LLINKID + integer mpp_nlinks, yw_mpp_nlinks, LNLINKSL +#endif + INTEGER(kind=int64), allocatable, DIMENSION(:,:) :: CH_LNKRT_SL !-- reach based links used for mapping + + + REAL, allocatable, DIMENSION(:,:) :: OVROUGHRTFAC,RETDEPRTFAC + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR AGGREGATION/DISAGGREGATION + REAL, allocatable, DIMENSION(:,:,:) :: SH2OWGT,SICE ! SMCRT, SMCMAXRT, SMCWLTRT moved to subsurface grid transform module + REAL, allocatable, DIMENSION(:,:) :: INFXSAGGRT + !REAL, allocatable, DIMENSION(:,:) :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT ! dhrt and qbdryrt moved to overland control qstrmvolrt and lake_inflrt moved to overland stream and lakes + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_ACC, LAKE_INFLORT_DUM + REAL, allocatable, DIMENSION(:,:) :: INFXSWGT, ywtmp + REAL, allocatable, DIMENSION(:) :: SMCAGGRT,STCAGGRT,SH2OAGGRT + REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT + !REAL, allocatable, DIMENSION(:,:,:) :: dist ! 8 direction of distance moved to overland properties +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR ONLINE MASS BALANCE CALCULATION + REAL(KIND=8) :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF + REAL(KIND=8) :: RESID,SUMEVP,DUG1RNFF,DUG2RNFF,DETP ! DSMCTOT, SMCTOT1, SMCTOT2 moved to overland mass balance + REAL(KIND=8) :: suminfxs2,dprcp_ts ! suminfxsrt, suminfxs1 moved to overland mass balance + REAL(KIND=8) :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT + REAL(KIND=8) :: CHAN_INV,LAKE_INV !-channel and lake inflow in volume + REAL(KIND=8) :: DQBDRY + REAL :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL + REAL(KIND=8), allocatable, DIMENSION(:) :: DSMC,SMCRTCHK + REAL(KIND=8), allocatable, DIMENSION(:,:) :: CMC_INIT,SWE_INIT +! REAL(KIND=8), allocatable, DIMENSION(:,:,:) :: SMC_INIT + REAL(KIND=8) :: SMC_INIT,SMC_FINAL,resid2,resid1 + REAL(KIND=8) :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av + + integer :: g_ixrt,g_jxrt,flag + integer :: allo_status = -99 + integer iywtmp + + +!-- lake params + REAL, allocatable, DIMENSION(:) :: LAKEMAXH !maximum depth (m) + REAL, allocatable, DIMENSION(:) :: WEIRC !coeff of overtop weir + REAL, allocatable, DIMENSION(:) :: WEIRH !depth of Lake coef + + + + +!DJG Modified namelist for routing and agg. variables + real Z_tmp + + !!! define land surface grid variables + REAL, allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX + REAL, allocatable, DIMENSION(:,:) :: SMCMAX1,SMCWLT1,SMCREF1 + INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP + REAL, allocatable, DIMENSION(:,:) :: OV_ROUGH2d + !REAL, allocatable, DIMENSION(:) :: SLDPTH + REAL, allocatable, DIMENSION(:,:) :: NEXP + +!!! define constant/parameter + real :: ov_rough(50)!, ZSOIL(100) ! ZSOIL moved to subsurface properties module +! out_counts: couput counts for current run. +! his_out_counts: used for channel routing output and special for restart. +! his_out_counts = previous run + out_counts + integer :: out_counts, rst_counts, his_out_counts + + REAL, allocatable, DIMENSION(:,:) :: lat_lsm, lon_lsm + REAL, allocatable, DIMENSION(:,:,:) :: dist_lsm + + END TYPE RT_FIELD +end module module_rt_inc diff --git a/hydro/Debug_Utilities/CMakeLists.txt b/hydro/Debug_Utilities/CMakeLists.txt new file mode 100644 index 0000000000..da145d69c1 --- /dev/null +++ b/hydro/Debug_Utilities/CMakeLists.txt @@ -0,0 +1,4 @@ +# build the version static library +add_library(hydro_debug_utils STATIC + debug_dump_variable.F90 +) diff --git a/hydro/Debug_Utilities/Makefile b/hydro/Debug_Utilities/Makefile index bbba71179f..0db4c91319 100644 --- a/hydro/Debug_Utilities/Makefile +++ b/hydro/Debug_Utilities/Makefile @@ -1,18 +1,18 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros OBJS = \ - debug_dump_variable.o + debug_dump_variable.o -all: $(OBJS) +all: $(OBJS) -.F.o: +.F90.o: @echo "" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I../mod $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I../mod $(*).F90 @echo "" ar -r ../lib/libHYDRO.a $(@) cp *.mod ../mod diff --git a/hydro/Debug_Utilities/debug_dump_variable.F b/hydro/Debug_Utilities/debug_dump_variable.F90 similarity index 100% rename from hydro/Debug_Utilities/debug_dump_variable.F rename to hydro/Debug_Utilities/debug_dump_variable.F90 diff --git a/hydro/HYDRO_drv/CMakeLists.txt b/hydro/HYDRO_drv/CMakeLists.txt new file mode 100644 index 0000000000..801930bda5 --- /dev/null +++ b/hydro/HYDRO_drv/CMakeLists.txt @@ -0,0 +1,21 @@ +# build the version static library +add_library(hydro_driver STATIC + module_HYDRO_drv.F90 +) + +target_link_libraries(hydro_driver PUBLIC + hydro_mpp + hydro_data_rec + hydro_routing + hydro_debug_utils +) + +if(WRF_HYDRO_NUDGING STREQUAL "1") + target_link_libraries(hydro_driver PUBLIC hydro_nudging) +endif() + +target_include_directories(hydro_driver + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) diff --git a/hydro/HYDRO_drv/Makefile b/hydro/HYDRO_drv/Makefile index 0bb462e09b..4201546bb1 100644 --- a/hydro/HYDRO_drv/Makefile +++ b/hydro/HYDRO_drv/Makefile @@ -1,17 +1,17 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros OBJS = \ module_HYDRO_drv.o -all: $(OBJS) +all: $(OBJS) -.F.o: +.F90.o: @echo "" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) -I../mod $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) -I../mod $(*).F90 @echo "" ar -r ../lib/libHYDRO.a $(@) cp *.mod ../mod diff --git a/hydro/HYDRO_drv/module_HYDRO_drv.F b/hydro/HYDRO_drv/module_HYDRO_drv.F90 similarity index 99% rename from hydro/HYDRO_drv/module_HYDRO_drv.F rename to hydro/HYDRO_drv/module_HYDRO_drv.F90 index daeaa1c35c..63959f0cd0 100644 --- a/hydro/HYDRO_drv/module_HYDRO_drv.F +++ b/hydro/HYDRO_drv/module_HYDRO_drv.F90 @@ -977,7 +977,7 @@ subroutine driveChannelRouting(did) RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & RT_DOMAIN(did)%Bw,RT_DOMAIN(did)%Tw,RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & - RT_DOMAIN(did)%ChannK,& + RT_DOMAIN(did)%ChannK,& RT_DOMAIN(did)%RESHT, & RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& @@ -990,7 +990,7 @@ subroutine driveChannelRouting(did) ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & RT_DOMAIN(did)%yw_mpp_nlinks & - , RT_DOMAIN(did)%LNLINKSL,RT_DOMAIN(did)%LLINKID & + , RT_DOMAIN(did)%LNLINKSL & , rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd & #endif , rt_domain(did)%CH_LNKRT_SL & diff --git a/hydro/IO/CMakeLists.txt b/hydro/IO/CMakeLists.txt new file mode 100644 index 0000000000..80dc6e22a3 --- /dev/null +++ b/hydro/IO/CMakeLists.txt @@ -0,0 +1,14 @@ +# build the orchestrator static library +add_library(hydro_netcdf_layer STATIC + netcdf_layer.F90 +) + +target_link_libraries(hydro_netcdf_layer + MPI::MPI_Fortran +) + +target_include_directories(hydro_netcdf_layer + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) diff --git a/hydro/IO/Makefile b/hydro/IO/Makefile index 6eed9de0b7..b0530be1a6 100644 --- a/hydro/IO/Makefile +++ b/hydro/IO/Makefile @@ -1,7 +1,7 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .f90 +.SUFFIXES: .o .F90 include ../macros @@ -9,11 +9,11 @@ OBJS = \ netcdf_layer.o all: $(OBJS) -.f90.o: +.F90.o: @echo "" # $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f # $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) -I../mod $(*).f90 + $(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) -I../mod $(*).F90 # $(RMD) $(*).f @echo "" ar -r ../lib/libHYDRO.a $(@) diff --git a/hydro/IO/netcdf_layer.f90 b/hydro/IO/netcdf_layer.F90 similarity index 100% rename from hydro/IO/netcdf_layer.f90 rename to hydro/IO/netcdf_layer.F90 diff --git a/hydro/MPP/CMakeLists.txt b/hydro/MPP/CMakeLists.txt new file mode 100644 index 0000000000..1eb929cc95 --- /dev/null +++ b/hydro/MPP/CMakeLists.txt @@ -0,0 +1,12 @@ +add_library(hydro_mpp STATIC + CPL_WRF.F90 + module_mpp_GWBUCKET.F90 + module_mpp_ReachLS.F90 + mpp_land.F90 + hashtable.F90 +) + +target_link_libraries(hydro_mpp MPI::MPI_Fortran) +target_include_directories(hydro_mpp PUBLIC + ${MPI_Fortran_MODULE_DIR} +) diff --git a/hydro/MPP/CPL_WRF.F b/hydro/MPP/CPL_WRF.F90 similarity index 92% rename from hydro/MPP/CPL_WRF.F rename to hydro/MPP/CPL_WRF.F90 index 03cbea5900..e0e0207870 100644 --- a/hydro/MPP/CPL_WRF.F +++ b/hydro/MPP/CPL_WRF.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: ! This is used as a coupler with the WRF model. @@ -28,7 +28,7 @@ MODULE MODULE_CPL_LAND integer, public :: HYDRO_COMM_WORLD = MPI_COMM_NULL integer my_global_id - + integer total_pe_num integer global_ix,global_jx @@ -60,12 +60,12 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) integer ierr logical mpi_inited integer istart,iend,jstart,jend - + integer :: xx, ndim integer, dimension(0:1) :: dims, coords logical cyclic(0:1), reorder data cyclic/.false.,.false./ ! not cyclic - data reorder/.false./ + data reorder/.false./ CALL mpi_initialized( mpi_inited, ierr ) if ( .NOT. mpi_inited ) then @@ -103,27 +103,27 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) dims(0) = 0 dims(1) = 0 do xx=1,total_pe_num - if(node_info(2,xx) .eq. (-1)) then - dims(0) = dims(0)+1 - endif - if(node_info(4,xx) .eq. (-1)) then - dims(1) = dims(1)+1 - endif + if(node_info(2,xx) .eq. (-1)) then + dims(0) = dims(0)+1 + endif + if(node_info(4,xx) .eq. (-1)) then + dims(1) = dims(1)+1 + endif enddo - + ndim = 2 np_up_down = dims(0) np_left_right = dims(1) call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & cyclic, reorder, cartGridComm, ierr) - + call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) - + p_up_down = coords(0) p_left_right = coords(1) - initialized = .false. ! land model need to be initialized. + initialized = .false. ! land model need to be initialized. return END subroutine CPL_LAND_INIT @@ -132,18 +132,18 @@ subroutine send_info() integer,allocatable,dimension(:,:) :: tmp_info integer ierr, i,size, tag integer mpp_status(MPI_STATUS_SIZE) - tag = 9 + tag = 9 size = 9 if(my_global_id .eq. 0) then - do i = 1, total_pe_num-1 + do i = 1, total_pe_num-1 call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) enddo else call mpi_send(node_info(:,my_global_id+1),size, & MPI_INTEGER,0,tag,HYDRO_COMM_WORLD,ierr) - endif + endif call MPI_barrier( HYDRO_COMM_WORLD ,ierr) @@ -159,16 +159,16 @@ end subroutine send_info subroutine find_left() implicit none integer i - + node_info(2,my_global_id+1) = -1 - do i = 1, total_pe_num + do i = 1, total_pe_num if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then node_info(2,my_global_id+1) = i - 1 return - endif + endif end do return end subroutine find_left @@ -176,16 +176,16 @@ end subroutine find_left subroutine find_right() implicit none integer i - + node_info(3,my_global_id+1) = -1 - do i = 1, total_pe_num + do i = 1, total_pe_num if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then node_info(3,my_global_id+1) = i - 1 return - endif + endif end do return end subroutine find_right @@ -193,16 +193,16 @@ end subroutine find_right subroutine find_up() implicit none integer i - + node_info(4,my_global_id+1) = -1 - do i = 1, total_pe_num + do i = 1, total_pe_num if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then node_info(4,my_global_id+1) = i - 1 return - endif + endif end do return end subroutine find_up @@ -210,16 +210,16 @@ end subroutine find_up subroutine find_down() implicit none integer i - + node_info(5,my_global_id+1) = -1 - do i = 1, total_pe_num + do i = 1, total_pe_num if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then node_info(5,my_global_id+1) = i - 1 return - endif + endif end do return end subroutine find_down diff --git a/hydro/MPP/Makefile b/hydro/MPP/Makefile index 8ddb081456..d5f3bb5e92 100644 --- a/hydro/MPP/Makefile +++ b/hydro/MPP/Makefile @@ -1,7 +1,7 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros @@ -9,37 +9,37 @@ OBJS = hashtable.o CPL_WRF.o mpp_land.o module_mpp_ReachLS.o module_mpp_GWBUCKE all: $(OBJS) -hashtable.o: hashtable.F +hashtable.o: hashtable.F90 @echo "" $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F90 cp hashtable.mod ../mod ar -r ../lib/libHYDRO.a $(@) -mpp_land.o: mpp_land.F +mpp_land.o: mpp_land.F90 @echo "" $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F90 ar -r ../lib/libHYDRO.a $(@) -CPL_WRF.o: CPL_WRF.F +CPL_WRF.o: CPL_WRF.F90 @echo "" $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) $(*).F - - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -I$(NETCDFINC) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) $(*).F90 + + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F90 ar -r ../lib/libHYDRO.a $(@) -module_mpp_ReachLS.o: module_mpp_ReachLS.F +module_mpp_ReachLS.o: module_mpp_ReachLS.F90 @echo "" $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F90 ar -r ../lib/libHYDRO.a $(@) -module_mpp_GWBUCKET.o: module_mpp_GWBUCKET.F +module_mpp_GWBUCKET.o: module_mpp_GWBUCKET.F90 @echo "" $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F90 ar -r ../lib/libHYDRO.a $(@) clean: diff --git a/hydro/MPP/hashtable.F b/hydro/MPP/hashtable.F90 similarity index 99% rename from hydro/MPP/hashtable.F rename to hydro/MPP/hashtable.F90 index ecb6431c33..3dacc55d33 100644 --- a/hydro/MPP/hashtable.F +++ b/hydro/MPP/hashtable.F90 @@ -135,7 +135,7 @@ subroutine set_all_idx(this, keys, length) else n = size(keys) end if - + this%n_buckets = n allocate(this%buckets(n)) @@ -224,7 +224,7 @@ subroutine clear(this) if (.not. allocated(this%buckets)) return do i = 1, size(this%buckets) - if (associated(this%buckets(i)%next)) then + if (associated(this%buckets(i)%next)) then call this%buckets(i)%next%node_clear() deallocate(this%buckets(i)%next) if(allocated(this%buckets(i)%kv)) then diff --git a/hydro/MPP/module_mpp_GWBUCKET.F b/hydro/MPP/module_mpp_GWBUCKET.F90 similarity index 100% rename from hydro/MPP/module_mpp_GWBUCKET.F rename to hydro/MPP/module_mpp_GWBUCKET.F90 diff --git a/hydro/MPP/module_mpp_ReachLS.F b/hydro/MPP/module_mpp_ReachLS.F90 similarity index 100% rename from hydro/MPP/module_mpp_ReachLS.F rename to hydro/MPP/module_mpp_ReachLS.F90 diff --git a/hydro/MPP/mpp_land.F b/hydro/MPP/mpp_land.F deleted file mode 100644 index 9de75f0bf8..0000000000 --- a/hydro/MPP/mpp_land.F +++ /dev/null @@ -1,2820 +0,0 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - -!#### This is a module for parallel Land model. -MODULE MODULE_MPP_LAND - - use MODULE_CPL_LAND - use mpi - use iso_fortran_env, only: int64 - - IMPLICIT NONE - !integer, public :: HYDRO_COMM_WORLD ! communicator for WRF-Hydro - moved to MODULE_CPL_LAND - integer, public :: left_id,right_id,up_id,down_id,my_id - integer, public :: left_right_np,up_down_np ! define total process in two dimensions. - integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography. - integer, public :: IO_id ! the number for IO. (Last processor for IO) - integer, public :: global_nx, global_ny, local_nx,local_ny - integer, public :: global_rt_nx, global_rt_ny - integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT - integer, public :: numprocs ! total process, get by mpi initialization. - integer :: local_startx, local_starty - integer :: local_startx_rt, local_starty_rt, local_endx_rt, local_endy_rt - - integer mpp_status(MPI_STATUS_SIZE) - - integer overlap_n - integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size - integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size - integer, allocatable, DIMENSION(:), public :: startx,starty - integer, allocatable, DIMENSION(:), public :: mpp_nlinks - - interface check_land - module procedure check_landreal1 - module procedure check_landreal1d - module procedure check_landreal2d - module procedure check_landreal3d - end interface - interface write_io_land - module procedure write_io_real3d - end interface - interface mpp_land_bcast - module procedure mpp_land_bcast_real2 - module procedure mpp_land_bcast_real_1d - module procedure mpp_land_bcast_real8_1d - module procedure mpp_land_bcast_real1 - module procedure mpp_land_bcast_real1_double - module procedure mpp_land_bcast_char1d - module procedure mpp_land_bcast_char1 - module procedure mpp_land_bcast_int1 - module procedure mpp_land_bcast_int1d - module procedure mpp_land_bcast_int2d - module procedure mpp_land_bcast_logical - - end interface - - contains - - subroutine LOG_MAP2d() - implicit none - integer :: ndim, ierr - integer, dimension(0:1) :: dims, coords - - logical cyclic(0:1), reorder - data cyclic/.false.,.false./ ! not cyclic - data reorder/.false./ - - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) - - call getNX_NY(numprocs, left_right_np,up_down_np) - if(my_id.eq.IO_id) then -#ifdef HYDRO_D - write(6,*) "" - write(6,*) "total process:",numprocs - write(6,*) "left_right_np =", left_right_np,& - "up_down_np=",up_down_np -#endif - end if - -! ### get the row and column of the current process in the logical topography. -! ### left --> right, 0 -->left_right_np -1 -! ### up --> down, 0 --> up_down_np -1 - left_right_p = mod(my_id , left_right_np) - up_down_p = my_id / left_right_np - -! ### get the neighbors. -1 means no neighbor. - down_id = my_id - left_right_np - up_id = my_id + left_right_np - if( up_down_p .eq. 0) down_id = -1 - if( up_down_p .eq. (up_down_np-1) ) up_id = -1 - - left_id = my_id - 1 - right_id = my_id + 1 - if( left_right_p .eq. 0) left_id = -1 - if( left_right_p .eq. (left_right_np-1) ) right_id =-1 - -! ### the IO node is the last processor. -!yw IO_id = numprocs - 1 - IO_id = 0 - -! print the information for debug. - -! BF setup virtual cartesian grid topology - ndim = 2 - - dims(0) = up_down_np ! rows - dims(1) = left_right_np ! columns -! - call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & - cyclic, reorder, cartGridComm, ierr) - - call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) - - p_up_down = coords(0) - p_left_right = coords(1) - np_up_down = up_down_np - np_left_right = left_right_np - - - call mpp_land_sync() - - return - end subroutine log_map2d - - - !old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs) - subroutine MPP_LAND_INIT(in_global_nx,in_global_ny) -! ### initialize the land model logically based on the two D method. -! ### Call this function directly if it is nested with WRF. - implicit none - integer, optional :: in_global_nx, in_global_ny - integer :: ierr, provided - integer :: ew_numprocs, sn_numprocs ! input the processors in x and y direction. - logical mpi_inited - - global_nx = in_global_nx - global_ny = in_global_ny - - ! left_right_np = ew_numprocs - ! up_down_np = sn_numprocs - - call mpi_initialized( mpi_inited, ierr ) - if ( .not. mpi_inited ) then - call MPI_INIT_THREAD( MPI_THREAD_FUNNELED, provided, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_INIT failed") - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_DUP failed") - endif - - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_RANK and/or MPI_COMM_SIZE failed") - - ! create 2d logical mapping of the CPU. - call log_map2d() - return - end subroutine MPP_LAND_INIT - - - subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) - integer in_global_nx,in_global_ny, AGGFACTRT - integer :: over_lap ! the overlaped grid number. (default is 1) - integer :: i - - global_nx = in_global_nx - global_ny = in_global_ny - rt_AGGFACTRT = AGGFACTRT - global_rt_nx = in_global_nx*AGGFACTRT - global_rt_ny = in_global_ny *AGGFACTRT - !overlap_n = 1 -!ywold local_nx = global_nx / left_right_np -!ywold if(left_right_p .eq. (left_right_np-1) ) then -!ywold local_nx = global_nx & -!ywold -int(global_nx/left_right_np)*(left_right_np-1) -!ywold end if -!ywold local_ny = global_ny / up_down_np -!ywold if( up_down_p .eq. (up_down_np-1) ) then -!ywold local_ny = global_ny & -!ywold -int(global_ny/up_down_np)*(up_down_np -1) -!ywold end if - - local_nx = int(global_nx / left_right_np) - !if(global_nx .ne. (local_nx*left_right_np) ) then - if(mod(global_nx, left_right_np) .ne. 0) then - do i = 1, mod(global_nx, left_right_np) - if(left_right_p .eq. i ) then - local_nx = local_nx + 1 - end if - end do - end if - - local_ny = int(global_ny / up_down_np) - !if(global_ny .ne. (local_ny * up_down_np) ) then - if(mod(global_ny,up_down_np) .ne. 0 ) then - do i = 1, mod(global_ny,up_down_np) - if( up_down_p .eq. i) then - local_ny = local_ny + 1 - end if - end do - end if - - local_rt_nx=local_nx*AGGFACTRT+2 - local_rt_ny=local_ny*AGGFACTRT+2 - if(left_id.lt.0) local_rt_nx = local_rt_nx -1 - if(right_id.lt.0) local_rt_nx = local_rt_nx -1 - if(up_id.lt.0) local_rt_ny = local_rt_ny -1 - if(down_id.lt.0) local_rt_ny = local_rt_ny -1 - - call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny) - call calculate_start_p() - - in_global_nx = local_nx - in_global_ny = local_ny -#ifdef HYDRO_D - write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx - write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny - write(6,*) "my_id=",my_id,"global_nx=",global_nx - write(6,*) "my_id=",my_id,"global_nx=",global_ny -#endif - return - end subroutine MPP_LAND_PAR_INI - - subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) -! ### Communicate message on left right direction. - integer NX,NY - real in_out_data(nx,ny),data_r(2,ny) - integer count,size,tag, ierr - integer flag ! 99 replace the boundary, else get the sum. - - if(flag .eq. 99) then ! replace the data - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & - right_id,tag,HYDRO_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = ny - call mpi_recv(in_out_data(1,:),size,MPI_REAL, & - left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = ny - tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_REAL, & - left_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& - right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - endif - - else ! get the sum - - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & - right_id,tag,HYDRO_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = 2*ny - call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & - HYDRO_COMM_WORLD,mpp_status,ierr) - in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) - in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = 2*ny - tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & - left_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& - right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - endif - endif ! end if black for flag. - - return - end subroutine MPP_LAND_LR_COM - - subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) -! ### Communicate message on left right direction. - integer NX,NY - real*8 in_out_data(nx,ny),data_r(2,ny) - integer count,size,tag, ierr - integer flag ! 99 replace the boundary, else get the sum. - - if(flag .eq. 99) then ! replace the data - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & - right_id,tag,HYDRO_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = ny - call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = ny - tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& - right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - endif - - else ! get the sum - - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & - right_id,tag,HYDRO_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = 2*ny - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & - HYDRO_COMM_WORLD,mpp_status,ierr) - in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) - in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = 2*ny - tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& - right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - endif - endif ! end if black for flag. - - return - end subroutine MPP_LAND_LR_COM8 - - - subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) - integer local_nx, local_ny, rt_nx,rt_ny - integer i,status,ierr, tag - integer tmp_nx,tmp_ny -! ### if it is IO node, get the local_size of the x and y direction -! ### for all other tasks. - integer s_r(2) - -! if(my_id .eq. IO_id) then - if(.not. allocated(local_nx_size) ) allocate(local_nx_size(numprocs),stat = status) - if(.not. allocated(local_ny_size) ) allocate(local_ny_size(numprocs),stat = status) - if(.not. allocated(local_rt_nx_size) ) allocate(local_rt_nx_size(numprocs),stat = status) - if(.not. allocated(local_rt_ny_size) ) allocate(local_rt_ny_size(numprocs),stat = status) -! end if - - call mpp_land_sync() - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 1 - call mpi_recv(s_r,2,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - local_nx_size(i+1) = s_r(1) - local_ny_size(i+1) = s_r(2) - else - local_nx_size(i+1) = local_nx - local_ny_size(i+1) = local_ny - end if - end do - else - tag = 1 - s_r(1) = local_nx - s_r(2) = local_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 2 - call mpi_recv(s_r,2,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - local_rt_nx_size(i+1) = s_r(1) - local_rt_ny_size(i+1) = s_r(2) - else - local_rt_nx_size(i+1) = rt_nx - local_rt_ny_size(i+1) = rt_ny - end if - end do - else - tag = 2 - s_r(1) = rt_nx - s_r(2) = rt_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - call mpp_land_sync() - return - end subroutine get_local_size - - - subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) -! ### Communicate message on up down direction. - integer NX,NY - real in_out_data(nx,ny),data_r(nx,2) - integer count,size,tag, status, ierr - integer flag ! 99 replace the boundary , else get the sum of the boundary - - - if(flag .eq. 99) then ! replace the boundary data. - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & - up_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx - call mpi_recv(in_out_data(:,1),size,MPI_REAL, & - down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx - call mpi_send(in_out_data(:,2),size,MPI_REAL, & - down_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & - up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - - else ! flag = 1 - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & - up_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx*2 - call mpi_recv(data_r,size,MPI_REAL, & - down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) - in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & - down_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & - up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - endif ! end of block flag - return - end subroutine MPP_LAND_UB_COM - - subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) -! ### Communicate message on up down direction. - integer NX,NY - real*8 in_out_data(nx,ny),data_r(nx,2) - integer count,size,tag, status, ierr - integer flag ! 99 replace the boundary , else get the sum of the boundary - - - if(flag .eq. 99) then ! replace the boundary data. - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & - up_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx - call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & - down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx - call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & - down_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - - else ! flag = 1 - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx*2 - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & - down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) - in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) - in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & - down_id,tag,HYDRO_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - endif ! end of block flag - return - end subroutine MPP_LAND_UB_COM8 - - subroutine calculate_start_p() -! calculate startx and starty - integer :: i,status, ierr, tag - integer :: r_s(2) - integer :: t_nx, t_ny - - if(.not. allocated(starty) ) allocate(starty(numprocs),stat = ierr) - if(.not. allocated(startx) ) allocate(startx(numprocs),stat = ierr) - - local_startx = int(global_nx/left_right_np) * left_right_p+1 - local_starty = int(global_ny/up_down_np) * up_down_p+1 - -!ywold - t_nx = 0 - do i = 1, mod(global_nx,left_right_np) - if(left_right_p .gt. i ) then - t_nx = t_nx + 1 - end if - end do - local_startx = local_startx + t_nx - - t_ny = 0 - do i = 1, mod(global_ny,up_down_np) - if( up_down_p .gt. i) then - t_ny = t_ny + 1 - end if - end do - local_starty = local_starty + t_ny - - - if(left_id .lt. 0) local_startx = 1 - if(down_id .lt. 0) local_starty = 1 - - - if(my_id .eq. IO_id) then - startx(my_id+1) = local_startx - starty(my_id+1) = local_starty - end if - - r_s(1) = local_startx - r_s(2) = local_starty - call mpp_land_sync() - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ! block receive from other node. - if(i.ne.my_id) then - tag = 1 - call mpi_recv(r_s,2,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - startx(i+1) = r_s(1) - starty(i+1) = r_s(2) - end if - end do - else - tag = 1 - call mpi_send(r_s,2,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - - call mpp_land_sync() - -! calculate the routing land start x and y - local_startx_rt = local_startx*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(local_startx_rt.gt.1) local_startx_rt=local_startx_rt - 1 - local_starty_rt = local_starty*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(local_starty_rt.gt.1) local_starty_rt=local_starty_rt - 1 - - local_endx_rt = local_startx_rt + local_rt_nx -1 - local_endy_rt = local_starty_rt + local_rt_ny -1 - - return - end subroutine calculate_start_p - - subroutine decompose_data_real3d (in_buff,out_buff,klevel) - implicit none - integer:: klevel, k - real,dimension(:,:,:) :: in_buff,out_buff - do k = 1, klevel - call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) - end do - end subroutine decompose_data_real3d - - - subroutine decompose_data_real (in_buff,out_buff) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - real,intent(in), dimension(:,:) :: in_buff - real,intent(out), dimension(local_nx,local_ny) :: out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) - end if - end do - else - size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_data_real - - - subroutine decompose_data_int (in_buff,out_buff) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer,dimension(:,:) :: in_buff,out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) - end if - end do - else - size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_data_int - - subroutine write_IO_int(in_buff,out_buff) -! the IO node will receive the data from the rest process. - integer,dimension(:,:):: in_buff, out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_nx*local_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_nx_size(i+1)*local_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_int - - subroutine write_IO_char_head(in, out, imageHead) - !! JLM 2015-11-30 - !! for i is image number (starting from 0), - !! this routine writes - !! in(1:imageHead(i+1)) - !! to - !! out( (sum(imageHead(i+1-1))+1) : ((sum(imageHead(i+1-1))+1)+imageHead(i+1)) ) - !! where out is on the IO node. - character(len=*), intent(in), dimension(:) :: in - character(len=*), intent(out), dimension(:) :: out - integer, intent(in), dimension(:) :: imageHead - integer :: tag, i, status, ierr, size - integer :: ibegin,iend,jbegin,jend - integer :: lenSize, theStart, theEnd - tag = 2 - if(my_id .ne. IO_id) then - lenSize = imageHead(my_id+1)*len(in(1)) !! some times necessary for character arrays? - if(lenSize .eq. 0) return - call mpi_send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs-1 - lenSize = imageHead(i+1)*len(in(1)) !! necessary? - if(lenSize .eq. 0) cycle - if(i .eq. 0) then - theStart = 1 - else - theStart = sum(imageHead(1:(i+1-1))) +1 - end if - theEnd = theStart + imageHead(i+1) -1 - if(i .eq. IO_id) then - out(theStart:theEnd) = in(1:imageHead(i+1)) - else - call mpi_recv(out(theStart:theEnd),lenSize,& - MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - end subroutine write_IO_char_head - - - subroutine write_IO_real3d(in_buff,out_buff,klevel) - implicit none -! the IO node will receive the data from the rest process. - integer klevel, k - real,dimension(:,:,:):: in_buff, out_buff - do k = 1, klevel - call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) - end do - end subroutine write_IO_real3d - - subroutine write_IO_real(in_buff,out_buff) -! the IO node will receive the data from the rest process. - real,dimension(:,:):: in_buff, out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_nx*local_ny - tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_nx_size(i+1)*local_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_real - - subroutine write_IO_RT_real(in_buff,out_buff) -! the IO node will receive the data from the rest process. - real,dimension(:,:) :: in_buff, out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_real - - - subroutine write_IO_RT_int (in_buff,out_buff) -! the IO node will receive the data from the rest process. - integer,intent(in),dimension(:,:) :: in_buff - integer,intent(out),dimension(:,:) :: out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_int - - subroutine write_IO_RT_int8(in_buff,out_buff) - ! the IO node will receive the data from the rest process. - integer(kind=int64),intent(in),dimension(:,:) :: in_buff - integer(kind=int64),intent(out),dimension(:,:) :: out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER8, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_int8 - - subroutine mpp_land_bcast_log1(inout) - logical inout - integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_log1 - - - subroutine mpp_land_bcast_int(size,inout) - integer size - integer inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_INTEGER, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int - - subroutine mpp_land_bcast_int8(size,inout) - integer size - integer(kind=int64) inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_INTEGER8, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int8 - - subroutine mpp_land_bcast_int8_1d(inout) - integer len - integer(kind=int64) inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER8, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int8_1d - - subroutine mpp_land_bcast_int1d(inout) - integer len - integer inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1d - - subroutine mpp_land_bcast_int1d_root(inout, rootId) - integer len - integer inout(:) - integer, intent(in) :: rootId - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1d_root - - subroutine mpp_land_bcast_int1(inout) - integer inout - integer ierr - call mpi_bcast(inout,1,MPI_INTEGER, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1 - - subroutine mpp_land_bcast_int1_root(inout, rootId) - integer inout - integer ierr - integer, intent(in) :: rootId - call mpi_bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1_root - - subroutine mpp_land_bcast_logical(inout) - logical :: inout - integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_logical - - subroutine mpp_land_bcast_logical_root(inout, rootId) - logical :: inout - integer, intent(in) :: rootId - integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_logical_root - - - subroutine mpp_land_bcast_real1(inout) - real inout - integer ierr - call mpi_bcast(inout,1,MPI_REAL, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real1 - - subroutine mpp_land_bcast_real1_double(inout) - real*8 inout - integer ierr - call mpi_bcast(inout,1,MPI_REAL8, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real1_double - - subroutine mpp_land_bcast_real_1d(inout) - integer len - real inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_real, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real_1d - - - subroutine mpp_land_bcast_real_1d_root(inout, rootId) - integer len - real inout(:) - integer, intent(in) :: rootId - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_real,rootId,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real_1d_root - - - subroutine mpp_land_bcast_real8_1d(inout) - integer len - real*8 inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_double, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real8_1d - - - subroutine mpp_land_bcast_real(size1,inout) - integer size1 - ! real inout(size1) - real , dimension(:) :: inout - integer ierr, len - call mpi_bcast(inout,size1,MPI_real, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real - - subroutine mpp_land_bcast_int2d(inout) - integer length1, k,length2 - integer inout(:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & - IO_id,HYDRO_COMM_WORLD,ierr) - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int2d - - subroutine mpp_land_bcast_real2(inout) - integer length1, k,length2 - real inout(:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_real, & - IO_id,HYDRO_COMM_WORLD,ierr) - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real2 - - subroutine mpp_land_bcast_real3d(inout) - integer j, k, length1, length2, length3 - real inout(:,:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - length3 = size(inout,3) - do k = 1, length3 - do j = 1, length2 - call mpi_bcast(inout(:,j,k), length1, MPI_real, & - IO_id, HYDRO_COMM_WORLD, ierr) - end do - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real3d - - subroutine mpp_land_bcast_rd(size,inout) - integer size - real*8 inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_REAL8, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_rd - - subroutine mpp_land_bcast_char(size,inout) - integer size - character inout(*) - integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char - - subroutine mpp_land_bcast_char_root(size,inout,rootId) - integer size - character inout(*) - integer, intent(in) :: rootId - integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char_root - - - subroutine mpp_land_bcast_char1d(inout) - character(len=*) :: inout(:) - integer :: lenSize - integer :: ierr - lenSize = size(inout,1)*len(inout) - call mpi_bcast(inout,lenSize,MPI_CHARACTER, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1d - - subroutine mpp_land_bcast_char1d_root(inout,rootId) - character(len=*) :: inout(:) - integer, intent(in) :: rootId - integer :: lenSize - integer :: ierr - lenSize = size(inout,1)*len(inout) - call mpi_bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1d_root - - subroutine mpp_land_bcast_char1(inout) - integer len - character(len=*) inout - integer ierr - len = LEN_TRIM(inout) - call mpi_bcast(inout,len,MPI_CHARACTER, & - IO_id,HYDRO_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1 - - - subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - real in_out_data(nx,ny) - - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - - return - end subroutine MPP_LAND_COM_REAL - - subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - real*8 in_out_data(nx,ny) - - call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) - - return - end subroutine MPP_LAND_COM_REAL8 - - subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - integer data(nx,ny) - real in_out_data(nx,ny) - - in_out_data = data + 0.0 - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - data = in_out_data + 0 - - return - end subroutine MPP_LAND_COM_INTEGER - - - subroutine MPP_LAND_COM_INTEGER8(data,NX,NY,flag) - ! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - integer(kind=int64) data(nx,ny) - real in_out_data(nx,ny) - - in_out_data = data + 0.0 - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - data = in_out_data + 0 - - return - end subroutine MPP_LAND_COM_INTEGER8 - - subroutine read_restart_3(unit,nz,out) - integer unit,nz,i - real buf3(global_nx,global_ny,nz),& - out(local_nx,local_ny,3) - if(my_id.eq.IO_id) read(unit) buf3 - do i = 1,nz - call decompose_data_real (buf3(:,:,i),out(:,:,i)) - end do - return - end subroutine read_restart_3 - - subroutine read_restart_2(unit,out) - integer unit,ierr2 - real buf2(global_nx,global_ny),& - out(local_nx,local_ny) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 - call mpp_land_bcast_int1(ierr2) - if(ierr2 .ne. 0) return - - call decompose_data_real (buf2,out) - return - end subroutine read_restart_2 - - subroutine read_restart_rt_2(unit,out) - integer unit,ierr2 - real buf2(global_rt_nx,global_rt_ny),& - out(local_rt_nx,local_rt_ny) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 - call mpp_land_bcast_int1(ierr2) - if(ierr2.ne.0) return - - call decompose_RT_real(buf2,out, & - global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - return - end subroutine read_restart_rt_2 - - subroutine read_restart_rt_3(unit,nz,out) - integer unit,nz,i,ierr2 - real buf3(global_rt_nx,global_rt_ny,nz),& - out(local_rt_nx,local_rt_ny,3) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3 - call mpp_land_bcast_int1(ierr2) - if(ierr2.ne.0) return - - do i = 1,nz - call decompose_RT_real (buf3(:,:,i),out(:,:,i),& - global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - end do - return - end subroutine read_restart_rt_3 - - subroutine write_restart_3(unit,nz,in) - integer unit,nz,i - real buf3(global_nx,global_ny,nz),& - in(local_nx,local_ny,nz) - do i = 1,nz - call write_IO_real(in(:,:,i),buf3(:,:,i)) - end do - if(my_id.eq.IO_id) write(unit) buf3 - return - end subroutine write_restart_3 - - subroutine write_restart_2(unit,in) - integer unit - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit) buf2 - return - end subroutine write_restart_2 - - subroutine write_restart_rt_2(unit,in) - integer unit - real buf2(global_rt_nx,global_rt_ny), & - in(local_rt_nx,local_rt_ny) - call write_IO_RT_real(in,buf2) - if(my_id.eq.IO_id) write(unit) buf2 - return - end subroutine write_restart_rt_2 - - subroutine write_restart_rt_3(unit,nz,in) - integer unit,nz,i - real buf3(global_rt_nx,global_rt_ny,nz),& - in(local_rt_nx,local_rt_ny,nz) - do i = 1,nz - call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) - end do - if(my_id.eq.IO_id) write(unit) buf3 - return - end subroutine write_restart_rt_3 - - subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - real,intent(in),dimension(:,:) :: in_buff - real,intent(out),dimension(:,:) :: out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_real - - subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - integer,intent(in),dimension(:,:) :: in_buff - integer,intent(out),dimension(:,:) :: out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - call mpp_land_sync() - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_int - - subroutine decompose_RT_int8 (in_buff,out_buff,g_nx,g_ny,nx,ny) - ! usage: all of the cpu call this subroutine. - ! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - integer(kind=int64),intent(in),dimension(:,:) :: in_buff - integer(kind=int64),intent(out),dimension(:,:) :: out_buff - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - call mpp_land_sync() - if(my_id == IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin > 1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin > 1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id == i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER8, i,tag,HYDRO_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER8,IO_id, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_int8 - - subroutine getNX_NY(nprocs,nx,ny) - ! calculate the nx and ny based on the total nprocs. - integer nprocs, nx, ny, n - integer i, j, max - - n = global_nx * global_ny - if( nprocs .ge. n ) then - call fatal_error_stop("Error: number of processes greater than number of cells in the land grid") - end if - - max = nprocs - do j = 1, nprocs - if( mod(nprocs,j) .eq. 0 ) then - i = nprocs/j - if( i .le. global_nx ) then - if( abs(i-j) .lt. max) then - if( j .le. global_ny ) then - max = abs(i-j) - nx = i - ny = j - end if - end if - end if - end if - end do - return - end subroutine getNX_NY - - subroutine pack_global_22(in, & - out,k) - integer ix,jx,k,i - real out(global_nx,global_ny,k) - real in(local_nx,local_ny,k) - do i = 1, k - call write_IO_real(in(:,:,i),out(:,:,i)) - enddo - return - end subroutine pack_global_22 - - - subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) - implicit none - integer total_pe - integer info(9,total_pe),AGGFACTRT - integer :: ierr, status - integer i - - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) - - if(numprocs .ne. total_pe) then - write(6,*) "FATAL ERROR: In wrf_LAND_set_INIT() - numprocs .ne. total_pe ",numprocs, total_pe - call mpp_land_abort() - endif - - -! ### get the neighbors. -1 means no neighbor. - left_id = info(2,my_id+1) - right_id = info(3,my_id+1) - up_id = info(4,my_id+1) - down_id = info(5,my_id+1) - IO_id = 0 - - allocate(local_nx_size(numprocs),stat = status) - allocate(local_ny_size(numprocs),stat = status) - allocate(local_rt_nx_size(numprocs),stat = status) - allocate(local_rt_ny_size(numprocs),stat = status) - allocate(starty(numprocs),stat = ierr) - allocate(startx(numprocs),stat = ierr) - - i = my_id + 1 - local_nx = info(7,i) - info(6,i) + 1 - local_ny = info(9,i) - info(8,i) + 1 - - global_nx = 0 - global_ny = 0 - do i = 1, numprocs - global_nx = max(global_nx,info(7,i)) - global_ny = max(global_ny,info(9,i)) - enddo - - local_rt_nx = local_nx*AGGFACTRT+2 - local_rt_ny = local_ny*AGGFACTRT+2 - if(left_id.lt.0) local_rt_nx = local_rt_nx -1 - if(right_id.lt.0) local_rt_nx = local_rt_nx -1 - if(up_id.lt.0) local_rt_ny = local_rt_ny -1 - if(down_id.lt.0) local_rt_ny = local_rt_ny -1 - - global_rt_nx = global_nx*AGGFACTRT - global_rt_ny = global_ny*AGGFACTRT - rt_AGGFACTRT = AGGFACTRT - - do i =1,numprocs - local_nx_size(i) = info(7,i) - info(6,i) + 1 - local_ny_size(i) = info(9,i) - info(8,i) + 1 - startx(i) = info(6,i) - starty(i) = info(8,i) - - local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2 - local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2 - if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 - if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 - if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 - if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 - enddo - return - end subroutine wrf_LAND_set_INIT - - subroutine getMy_global_id() - integer ierr - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - return - end subroutine getMy_global_id - - subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer(kind=int64) Link_location(ix,jy) - integer i,j, flag - real Link_V(size), tmp_inout(ix,jy) - - tmp_inout = -999 - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - -! commu nicate tmp_inout - call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_REAL - - - subroutine MPP_CHANNEL_COM_REAL8(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer(kind=int64) Link_location(ix,jy) - integer i,j, flag - real*8 :: Link_V(size), tmp_inout(ix,jy) - - tmp_inout = -999 - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - -! commu nicate tmp_inout - call MPP_LAND_COM_REAL8(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_REAL8 - - subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer(kind=int64) Link_location(ix,jy) - integer i,j, flag - integer(kind=int64) Link_V(size), tmp_inout(ix,jy) - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - - - -! commu nicate tmp_inout - call MPP_LAND_COM_INTEGER8(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_INT - - - subroutine print_2(unit,in,fm) - integer unit - character(len=*) fm - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit,*) buf2 - return - end subroutine print_2 - - subroutine print_rt_2(unit,in) - integer unit - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit,*) buf2 - return - end subroutine print_rt_2 - - subroutine mpp_land_max_int1(v) - implicit none - integer v, r1, max - integer i, ierr, tag - if(my_id .eq. IO_id) then - max = v - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 101 - call mpi_recv(r1,1,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - if(max <= r1) max = r1 - end if - end do - else - tag = 101 - call mpi_send(v,1,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - call mpp_land_bcast_int1(max) - v = max - return - end subroutine mpp_land_max_int1 - - subroutine mpp_land_max_real1(v) - implicit none - real v, r1, max - integer i, ierr, tag - if(my_id .eq. IO_id) then - max = v - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 101 - call mpi_recv(r1,1,MPI_REAL,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - if(max <= r1) max = r1 - end if - end do - else - tag = 101 - call mpi_send(v,1,MPI_REAL, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - call mpp_land_bcast_real1(max) - v = max - return - end subroutine mpp_land_max_real1 - - subroutine mpp_same_int1(v) - implicit none - integer v,r1 - integer i, ierr, tag - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 109 - call mpi_recv(r1,1,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - if(v .ne. r1) v = -99 - end if - end do - else - tag = 109 - call mpi_send(v,1,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - call mpp_land_bcast_int1(v) - end subroutine mpp_same_int1 - - - - subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks) - real recv(nlinks), v(nlinks) - ! real g_v(gnlinks), tmp_v(gnlinks) - integer i, ierr, tag, k - integer length, node, message_len - integer,allocatable,dimension(:) :: tmp_map - real, allocatable, dimension(:) :: tmp_v - real, dimension(:) :: g_v - - if(my_id .eq. io_id) then - allocate(tmp_map(gnlinks)) - allocate(tmp_v(gnlinks)) - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - else - allocate(tmp_map(1)) - allocate(tmp_v(1)) - endif - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - tag = 119 - - call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - node = tmp_map(k) - if(node .gt. 0) then - g_v(node) = tmp_v(k) - else -#ifdef HYDRO_D - write(6,*) "Maping infor k=",k," node=", node -#endif - endif - enddo - else - do k = 1,nlinks - node = map_l2g(k) - if(node .gt. 0) then - g_v(node) = v(k) - else -#ifdef HYDRO_D - write(6,*) "local Maping infor k=",k," node=",node -#endif - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_REAL,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - - end if - if(allocated(tmp_map)) deallocate(tmp_map) - if(allocated(tmp_v)) deallocate(tmp_v) - end subroutine write_chanel_real - - subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks) - integer :: recv(nlinks), v(nlinks) - integer, allocatable, dimension(:) :: tmp_map , tmp_v - integer, dimension(:) :: g_v - integer i, ierr, tag, k - integer length, node, message_len - - if(my_id .eq. io_id) then - allocate(tmp_map(gnlinks)) - allocate(tmp_v(gnlinks)) - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - else - allocate(tmp_map(1)) - allocate(tmp_v(1)) - endif - - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - tag = 119 - - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - if(tmp_map(k) .gt. 0) then - node = tmp_map(k) - g_v(node) = tmp_v(k) - else -#ifdef HYDRO_D - write(6,*) "Maping infor k=",k," node=",tmp_v(k) -#endif - endif - enddo - else - do k = 1,nlinks - if(map_l2g(k) .gt. 0) then - node = map_l2g(k) - g_v(node) = v(k) - else -#ifdef HYDRO_D - write(6,*) "Maping infor k=",k," node=",map_l2g(k) -#endif - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - if(allocated(tmp_map)) deallocate(tmp_map) - if(allocated(tmp_v)) deallocate(tmp_v) - end subroutine write_chanel_int - - subroutine write_chanel_int8(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks) - integer(kind=int64) :: recv(nlinks), v(nlinks) - integer(kind=int64), allocatable, dimension(:) :: tmp_v - integer, allocatable, dimension(:) :: tmp_map - integer(kind=int64), dimension(:) :: g_v - integer i, ierr, tag, k - integer length, node, message_len - - if(my_id .eq. io_id) then - allocate(tmp_map(gnlinks)) - allocate(tmp_v(gnlinks)) - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - else - allocate(tmp_map(1)) - allocate(tmp_v(1)) - endif - - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER8,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - if(tmp_map(k) .gt. 0) then - node = tmp_map(k) - g_v(node) = tmp_v(k) - else -#ifdef HYDRO_D - write(6,*) "Maping infor k=",k," node=",tmp_v(k) -#endif - endif - enddo - else - do k = 1,nlinks - if(map_l2g(k) .gt. 0) then - node = map_l2g(k) - g_v(node) = v(k) - else -#ifdef HYDRO_D - write(6,*) "Maping infor k=",k," node=",map_l2g(k) -#endif - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER8,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - if(allocated(tmp_map)) deallocate(tmp_map) - if(allocated(tmp_v)) deallocate(tmp_v) - end subroutine write_chanel_int8 - - - subroutine write_lake_real(v,nodelist_in,nlakes) - implicit none - real recv(nlakes), v(nlakes) - integer nodelist(nlakes), nlakes, nodelist_in(nlakes) - integer i, ierr, tag, k - integer length, node - - nodelist = nodelist_in - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - tag = 139 - call mpi_recv(recv(:),nlakes,MPI_REAL,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - - do k = 1,nlakes - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) - endif - enddo - end if - end do - else - tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - tag = 139 - call mpi_send(v,nlakes,MPI_REAL,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - end subroutine write_lake_real - - - subroutine write_lake_char(v,nodelist_in,nlakes) - implicit none - character(len=256) recv(nlakes), v(nlakes) - integer nodelist(nlakes), nlakes, nodelist_in(nlakes) - integer i, ierr, tag, k, in_len - integer length, node - - in_len = size(v, 1)*len(v) - - nodelist = nodelist_in - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - tag = 139 - call mpi_recv(recv(:),in_len,MPI_CHARACTER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - - do k = 1,nlakes - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) - endif - enddo - end if - end do - else - tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - tag = 139 - call mpi_send(v,in_len,MPI_CHARACTER,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - end subroutine write_lake_char - - - subroutine read_rst_crt_r(unit,out,size) - implicit none - integer unit, size, ierr,ierr2 - real out(size),out1(size) - if(my_id.eq.IO_id) then - read(unit,IOSTAT=ierr2,end=99) out1 - if(ierr2.eq.0) out=out1 - endif -99 continue - call mpp_land_bcast_int1(ierr2) - if(ierr2 .ne. 0) return - call mpi_bcast(out,size,MPI_REAL, & - IO_id,HYDRO_COMM_WORLD,ierr) - return - end subroutine read_rst_crt_r - - subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) - integer :: unit,gnlinks,nlinks,map_l2g(nlinks) - real cd(nlinks) - real g_cd (gnlinks) - call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) - write(unit) g_cd - return - end subroutine write_rst_crt_r - - subroutine sum_int1d(vin,nsize) - implicit none - integer nsize,i,j,tag,ierr - integer, dimension(nsize):: vin,recv - tag = 319 - if(nsize .le. 0) return - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - vin(:) = vin(:) + recv(:) - endif - end do - else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - call mpp_land_bcast_int1d(vin) - return - end subroutine sum_int1d - - subroutine combine_int1d(vin,nsize, flag) - implicit none - integer nsize,i,j,tag,ierr, flag, k - integer, dimension(nsize):: vin,recv - tag = 319 - if(nsize .le. 0) return - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(recv(k) .ne. flag) then - vin(k) = recv(k) - endif - enddo - endif - end do - else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - call mpp_land_bcast_int1d(vin) - return - end subroutine combine_int1d - - subroutine combine_int8_1d(vin,nsize, flag) - implicit none - integer nsize,i,j,tag,ierr, flag, k - integer(kind=int64), dimension(nsize):: vin,recv - tag = 319 - if(nsize .le. 0) return - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER8,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(recv(k) .ne. flag) then - vin(k) = recv(k) - endif - enddo - endif - end do - else - call mpi_send(vin,nsize,MPI_INTEGER8,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - call mpp_land_bcast_int8_1d(vin) - return - end subroutine combine_int8_1d - - subroutine sum_real1d(vin,nsize) - implicit none - integer :: nsize - real,dimension(nsize) :: vin - real*8,dimension(nsize) :: vin8 - vin8=vin - call sum_real8(vin8,nsize) - vin=vin8 - end subroutine sum_real1d - - subroutine sum_real8(vin,nsize) - implicit none - integer nsize,i,j,tag,ierr - real*8, dimension(nsize):: vin,recv - real, dimension(nsize):: v - tag = 319 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - vin(:) = vin(:) + recv(:) - endif - end do - v = vin - else - call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - call mpp_land_bcast_real(nsize,v) - vin = v - return - end subroutine sum_real8 - -! subroutine get_globalDim(ix,g_ix) -! implicit none -! integer ix,g_ix, ierr -! -! if ( my_id .eq. IO_id ) then -! g_ix = ix -! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & -! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) -! else -! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & -! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) -! endif -! call mpp_land_bcast_int1(g_ix) -! -! return -! -! end subroutine get_globalDim - - subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) - integer sg, s,e, size, s_in, e_in - integer index_s(2) - integer tag, ierr,i -! s: start index, e: end index - real vl(e_in-s_in+1), vg(sg) - s = s_in - e = e_in - - if(my_id .eq. IO_id) then - vg(s:e) = vl - end if - - index_s(1) = s - index_s(2) = e - size = e - s + 1 - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 202 - call mpi_recv(index_s,2,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - - tag = 203 - e = index_s(2) - s = index_s(1) - size = e - s + 1 - call mpi_recv(vg(s:e),size,MPI_REAL, & - i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - endif - end do - else - tag = 202 - call mpi_send(index_s,2,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - - tag = 203 - call mpi_send(vl,size,MPI_REAL,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - end if - - return - end subroutine gather_1d_real_tmp - - subroutine sum_real1(inout) - implicit none - real:: inout, send - integer :: ierr - send = inout - CALL MPI_ALLREDUCE(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) - end subroutine sum_real1 - - subroutine sum_double(inout) - implicit none - real*8:: inout, send - integer :: ierr - send = inout - !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) - CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) - end subroutine sum_double - - subroutine mpp_chrt_nlinks_collect(nlinks) - ! collect the nlinks - implicit none - integer :: nlinks - integer :: i, ierr, status, tag - allocate(mpp_nlinks(numprocs),stat = status) - tag = 138 - mpp_nlinks = 0 - if(my_id .eq. IO_id) then - do i = 0,numprocs -1 - if(i .ne. my_id) then - call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - else - mpp_nlinks(i+1) = 0 - end if - end do - else - call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - - - end subroutine mpp_chrt_nlinks_collect - - subroutine getLocalXY(ix,jx,startx,starty,endx,endy) -!!! this is for NoahMP only - implicit none - integer:: ix,jx,startx,starty,endx,endy - startx = local_startx - starty = local_starty - endx = startx + ix -1 - endy = starty + jx -1 - end subroutine getLocalXY - - subroutine check_landreal1(unit, inVar) - implicit none - integer :: unit - real :: inVar - if(my_id .eq. IO_id) then - write(unit,*) inVar - call flush(unit) - endif - end subroutine check_landreal1 - - subroutine check_landreal1d(unit, inVar) - implicit none - integer :: unit - real :: inVar(:) - if(my_id .eq. IO_id) then - write(unit,*) inVar - call flush(unit) - endif - end subroutine check_landreal1d - subroutine check_landreal2d(unit, inVar) - implicit none - integer :: unit - real :: inVar(:,:) - real :: g_var(global_nx,global_ny) - call write_io_real(inVar,g_var) - if(my_id .eq. IO_id) then - write(unit,*) g_var - call flush(unit) - endif - end subroutine check_landreal2d - - subroutine check_landreal3d(unit, inVar) - implicit none - integer :: unit, k, klevel - real :: inVar(:,:,:) - real :: g_var(global_nx,global_ny) - klevel = size(inVar,2) - do k = 1, klevel - call write_io_real(inVar(:,k,:),g_var) - if(my_id .eq. IO_id) then - write(unit,*) g_var - call flush(unit) - endif - end do - end subroutine check_landreal3d - - subroutine mpp_collect_1d_int(nlinks,vinout) - ! collect the nlinks - implicit none - integer :: nlinks - integer :: i, ierr, status, tag - integer, dimension(nlinks) :: vinout - integer, dimension(nlinks) :: buf - tag = 139 - call mpp_land_sync() - if(my_id .eq. IO_id) then - do i = 0,numprocs -1 - if(i .ne. my_id) then - call mpi_recv(buf,nlinks,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - vinout = vinout + buf - end if - end do - else - call mpi_send(vinout,nlinks,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - call mpp_land_sync() - call mpp_land_bcast_int1d(vinout) - - end subroutine mpp_collect_1d_int - - subroutine mpp_collect_1d_int_mem(nlinks,vinout) - ! consider the memory and big size data transport - ! collect the nlinks - implicit none - integer :: nlinks - integer :: i, ierr, status, tag - integer, dimension(nlinks) :: vinout, tmpIn - integer, dimension(nlinks) :: buf - integer :: lsize, k,m - integer, allocatable, dimension(:) :: tmpBuf - - call mpp_land_sync() - if(my_id .eq. IO_id) then - allocate (tmpBuf(nlinks)) - do i = 0,numprocs -1 - if(i .ne. my_id) then - tag = 120 - call mpi_recv(lsize,1,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - if(lsize .gt. 0) then - tag = 121 - call mpi_recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, lsize - m = tmpBuf(k) - vinout(m) = 1 - end do - endif - end if - end do - if(allocated(tmpBuf)) deallocate(tmpBuf) - else - lsize = 0 - do k = 1, nlinks - if(vinout(k) .gt. 0) then - lsize = lsize + 1 - tmpIn(lsize) = k - end if - end do - tag = 120 - call mpi_send(lsize,1,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - if(lsize .gt. 0) then - tag = 121 - call mpi_send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - endif - call mpp_land_sync() - call mpp_land_bcast_int1d(vinout) - - end subroutine mpp_collect_1d_int_mem - - subroutine updateLake_seqInt(in,nsize,in0) - implicit none - integer :: nsize - integer, dimension(nsize) :: in - integer, dimension(nsize) :: tmp - integer, dimension(:) :: in0 - integer tag, i, status, ierr, k - if(nsize .le. 0) return - - tag = 29 - if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& - MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(in0(k) .ne. tmp(k)) in(k) = tmp(k) - end do - end if - end do - end if - call mpp_land_bcast_int1d(in) - - end subroutine updateLake_seqInt - - subroutine updateLake_seqInt8(in,nsize,in0) - implicit none - integer :: nsize - integer(kind=int64), dimension(nsize) :: in - integer(kind=int64), dimension(nsize) :: tmp - integer(kind=int64), dimension(:) :: in0 - integer tag, i, status, ierr, k - if(nsize .le. 0) return - - tag = 29 - if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_INTEGER8, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& - MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(in0(k) .ne. tmp(k)) in(k) = tmp(k) - end do - end if - end do - end if - call mpp_land_bcast_int8_1d(in) - - end subroutine updateLake_seqInt8 - - - subroutine updateLake_seq(in,nsize,in0) - implicit none - integer :: nsize - real, dimension(nsize) :: in - real, dimension(nsize) :: tmp - real, dimension(:) :: in0 - integer tag, i, status, ierr, k - if(nsize .le. 0) return - - tag = 29 - if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_REAL, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& - MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(in0(k) .ne. tmp(k)) in(k) = tmp(k) - end do - end if - end do - end if - call mpp_land_bcast_real_1d(in) - - end subroutine updateLake_seq - - - subroutine updateLake_seq_char(in,nsize,in0) - implicit none - integer :: nsize - character(len=256), dimension(nsize) :: in - character(len=256), dimension(nsize) :: tmp - character(len=256), dimension(:) :: in0 - integer tag, i, status, ierr, k, in_len - if(nsize .le. 0) return - - in_len = size(in, 1)*len(in) - - tag = 29 - if(my_id .ne. IO_id) then - call mpi_send(in,in_len,MPI_CHARACTER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - if(i .ne. IO_id) then - call mpi_recv(tmp,in_len,& - MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(in0(k) .ne. tmp(k)) in(k) = tmp(k) - end do - end if - end do - end if - call mpp_land_bcast_char1d(in) - - end subroutine updateLake_seq_char - - - subroutine updateLake_grid(in,nsize,lake_index) - implicit none - integer :: nsize - real, dimension(nsize) :: in - integer, dimension(nsize) :: lake_index - real, dimension(nsize) :: tmp - integer tag, i, status, ierr, k - if(nsize .le. 0) return - - if(my_id .ne. IO_id) then - tag = 29 - call mpi_send(in,nsize,MPI_REAL, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - tag = 30 - call mpi_send(lake_index,nsize,MPI_INTEGER, IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - if(i .ne. IO_id) then - tag = 29 - call mpi_recv(tmp,nsize,& - MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - tag = 30 - call mpi_recv(lake_index,nsize,& - MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(lake_index(k) .gt. 0) in(k) = tmp(k) - end do - end if - end do - end if - call mpp_land_bcast_real_1d(in) - - end subroutine updateLake_grid - - -!subroutine match1dLake: -!global lake. Find the same lake and mark as flag -! default of win is 0 - subroutine match1dLake(vin,nsize,flag) - implicit none - integer nsize,i,j,tag,ierr, flag, k - integer, dimension(nsize):: vin,recv - tag = 319 - if(nsize .le. 0) return - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & - tag,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, nsize - if(recv(k) .eq. flag) vin(k) = flag - if(vin(k) .ne. flag) then - if(vin(k) .gt. 0 .and. recv(k) .gt. 0) then - vin(k) = flag - else - if(recv(k) .gt. 0) vin(k) = recv(k) - endif - endif - end do - endif - end do - else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & - tag,HYDRO_COMM_WORLD,ierr) - endif - call mpp_land_bcast_int1d(vin) - return - end subroutine match1dLake - - subroutine mpp_land_abort() - implicit none - integer ierr - CALL MPI_ABORT(HYDRO_COMM_WORLD,1,IERR) - end subroutine mpp_land_abort ! mpp_land_abort - - subroutine mpp_land_sync() - implicit none - integer ierr - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) - if(ierr .ne. 0) call mpp_land_abort() - return - end subroutine mpp_land_sync ! mpp_land_sync - - - subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) - implicit none - real, intent(inout) :: scalar - integer, intent(in) :: fromImage, toImage - integer:: ierr, tag - tag=2 - if(my_id .eq. fromImage) & - call mpi_send(scalar, 1, MPI_REAL, & - toImage, tag, HYDRO_COMM_WORLD, ierr) - if(my_id .eq. toImage) & - call mpi_recv(scalar, 1, MPI_REAL, & - fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) - end subroutine mpp_comm_scalar_real - - subroutine mpp_comm_scalar_char(scalar, fromImage, toImage) - implicit none - character(len=*), intent(inout) :: scalar - integer, intent(in) :: fromImage, toImage - integer:: ierr, tag, length - tag=2 - length=len(scalar) - if(my_id .eq. fromImage) & - call mpi_send(scalar, length, MPI_CHARACTER, & - toImage, tag, HYDRO_COMM_WORLD, ierr) - if(my_id .eq. toImage) & - call mpi_recv(scalar, length, MPI_CHARACTER, & - fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) - end subroutine mpp_comm_scalar_char - - - subroutine mpp_comm_1d_real(vector, fromImage, toImage) - implicit none - real, dimension(:), intent(inout) :: vector - integer, intent(in) :: fromImage, toImage - integer:: ierr, tag - integer:: my_id,numprocs - tag=2 - call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) - call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) - if(numprocs > 1) then - if(my_id .eq. fromImage) & - call mpi_send(vector, size(vector), MPI_REAL, & - toImage, tag, HYDRO_COMM_WORLD, ierr) - if(my_id .eq. toImage) & - call mpi_recv(vector, size(vector), MPI_REAL, & - fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) - endif - end subroutine mpp_comm_1d_real - - - subroutine mpp_comm_1d_char(vector, fromImage, toImage) - implicit none - character(len=*), dimension(:), intent(inout) :: vector - integer, intent(in) :: fromImage, toImage - integer:: ierr, tag, totalLength - integer:: my_id,numprocs - tag=2 - call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) - call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) - totalLength=len(vector(1))*size(vector,1) - if(numprocs > 1) then - if(my_id .eq. fromImage) & - call mpi_send(vector, totalLength, MPI_CHARACTER, & - toImage, tag, HYDRO_COMM_WORLD, ierr) - if(my_id .eq. toImage) & - call mpi_recv(vector, totalLength, MPI_CHARACTER, & - fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) - endif - end subroutine mpp_comm_1d_char - - -END MODULE MODULE_MPP_LAND diff --git a/hydro/MPP/mpp_land.F90 b/hydro/MPP/mpp_land.F90 new file mode 100644 index 0000000000..0084a2d166 --- /dev/null +++ b/hydro/MPP/mpp_land.F90 @@ -0,0 +1,2934 @@ +! Program Name: +! Author(s)/Contact(s): +! Abstract: +! History Log: +! +! Usage: +! Parameters: +! Input Files: +! +! Output Files: +! +! +! Condition codes: +! +! If appropriate, descriptive troubleshooting instructions or +! likely causes for failures could be mentioned here with the +! appropriate error code +! +! User controllable options: + +!#### This is a module for parallel Land model. +MODULE MODULE_MPP_LAND + + use MODULE_CPL_LAND + use mpi + use iso_fortran_env, only: int64 + + IMPLICIT NONE + !integer, public :: HYDRO_COMM_WORLD ! communicator for WRF-Hydro - moved to MODULE_CPL_LAND + integer, public :: left_id,right_id,up_id,down_id,my_id + integer, public :: left_right_np,up_down_np ! define total process in two dimensions. + integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography. + integer, public :: IO_id ! the number for IO. (Last processor for IO) + integer, public :: global_nx, global_ny, local_nx,local_ny + integer, public :: global_rt_nx, global_rt_ny + integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT + integer, public :: numprocs ! total process, get by mpi initialization. + integer :: local_startx, local_starty + integer :: local_startx_rt, local_starty_rt, local_endx_rt, local_endy_rt + + integer mpp_status(MPI_STATUS_SIZE) + + integer overlap_n + integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size + integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size + integer, allocatable, DIMENSION(:), public :: startx,starty + integer, allocatable, DIMENSION(:), public :: mpp_nlinks + + !dwj offset vectors and size vectors for scatterv and gatherv + integer, allocatable, dimension(:), public :: offset_vectors, offset_vectors_rt + integer, allocatable, dimension(:), public :: size_vectors, size_vectors_rt + + interface check_land + module procedure check_landreal1 + module procedure check_landreal1d + module procedure check_landreal2d + module procedure check_landreal3d + end interface + + interface write_io_land + module procedure write_io_real3d + end interface + + interface mpp_land_bcast + module procedure mpp_land_bcast_real2 + module procedure mpp_land_bcast_real_1d + module procedure mpp_land_bcast_real8_1d + module procedure mpp_land_bcast_real1 + module procedure mpp_land_bcast_real1_double + module procedure mpp_land_bcast_char1d + module procedure mpp_land_bcast_char1 + module procedure mpp_land_bcast_int1 + module procedure mpp_land_bcast_int1d + module procedure mpp_land_bcast_int2d + module procedure mpp_land_bcast_logical + end interface + +contains + + subroutine LOG_MAP2d() + implicit none + integer :: ndim, ierr + integer, dimension(0:1) :: dims, coords + + logical cyclic(0:1), reorder + data cyclic/.false.,.false./ ! not cyclic + data reorder/.false./ + + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + + call getNX_NY(numprocs, left_right_np,up_down_np) + if(my_id.eq.IO_id) then +#ifdef HYDRO_D + write(6,*) "" + write(6,*) "total process:",numprocs + write(6,*) "left_right_np =", left_right_np,& + "up_down_np=",up_down_np +#endif + end if + +! ### get the row and column of the current process in the logical topography. +! ### left --> right, 0 -->left_right_np -1 +! ### up --> down, 0 --> up_down_np -1 + left_right_p = mod(my_id , left_right_np) + up_down_p = my_id / left_right_np + +! ### get the neighbors. -1 means no neighbor. + down_id = my_id - left_right_np + up_id = my_id + left_right_np + if( up_down_p .eq. 0) down_id = -1 + if( up_down_p .eq. (up_down_np-1) ) up_id = -1 + + left_id = my_id - 1 + right_id = my_id + 1 + if( left_right_p .eq. 0) left_id = -1 + if( left_right_p .eq. (left_right_np-1) ) right_id =-1 + +! ### the IO node is the last processor. +!yw IO_id = numprocs - 1 + IO_id = 0 + +! print the information for debug. + +! BF setup virtual cartesian grid topology + ndim = 2 + + dims(0) = up_down_np ! rows + dims(1) = left_right_np ! columns +! + call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & + cyclic, reorder, cartGridComm, ierr) + + call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + + p_up_down = coords(0) + p_left_right = coords(1) + np_up_down = up_down_np + np_left_right = left_right_np + + return + end subroutine log_map2d + + subroutine MPP_LAND_INIT(in_global_nx,in_global_ny) +! ### initialize the land model logically based on the two D method. +! ### Call this function directly if it is nested with WRF. + implicit none + integer, optional :: in_global_nx, in_global_ny + integer :: ierr, provided + logical mpi_inited + + if (present(in_global_nx) .and. present(in_global_ny)) then + global_nx = in_global_nx + global_ny = in_global_ny + end if + + call mpi_initialized( mpi_inited, ierr ) + if ( .not. mpi_inited ) then + call MPI_INIT_THREAD( MPI_THREAD_FUNNELED, provided, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_INIT failed") + call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_DUP failed") + endif + + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_RANK and/or MPI_COMM_SIZE failed") + + ! create 2d logical mapping of the CPU. + call log_map2d() + return + end subroutine MPP_LAND_INIT + + + subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) + integer in_global_nx,in_global_ny, AGGFACTRT + integer :: over_lap ! the overlaped grid number. (default is 1) + integer :: i + + global_nx = in_global_nx + global_ny = in_global_ny + rt_AGGFACTRT = AGGFACTRT + global_rt_nx = in_global_nx*AGGFACTRT + global_rt_ny = in_global_ny *AGGFACTRT + !overlap_n = 1 +!ywold local_nx = global_nx / left_right_np +!ywold if(left_right_p .eq. (left_right_np-1) ) then +!ywold local_nx = global_nx & +!ywold -int(global_nx/left_right_np)*(left_right_np-1) +!ywold end if +!ywold local_ny = global_ny / up_down_np +!ywold if( up_down_p .eq. (up_down_np-1) ) then +!ywold local_ny = global_ny & +!ywold -int(global_ny/up_down_np)*(up_down_np -1) +!ywold end if + + local_nx = int(global_nx / left_right_np) + !if(global_nx .ne. (local_nx*left_right_np) ) then + if(mod(global_nx, left_right_np) .ne. 0) then + do i = 1, mod(global_nx, left_right_np) + if(left_right_p .eq. i ) then + local_nx = local_nx + 1 + end if + end do + end if + + local_ny = int(global_ny / up_down_np) + !if(global_ny .ne. (local_ny * up_down_np) ) then + if(mod(global_ny,up_down_np) .ne. 0 ) then + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .eq. i) then + local_ny = local_ny + 1 + end if + end do + end if + + local_rt_nx=local_nx*AGGFACTRT+2 + local_rt_ny=local_ny*AGGFACTRT+2 + if(left_id.lt.0) local_rt_nx = local_rt_nx -1 + if(right_id.lt.0) local_rt_nx = local_rt_nx -1 + if(up_id.lt.0) local_rt_ny = local_rt_ny -1 + if(down_id.lt.0) local_rt_ny = local_rt_ny -1 + + call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny) + call calculate_start_p() + call calculate_offset_vectors() + + in_global_nx = local_nx + in_global_ny = local_ny +#ifdef HYDRO_D + write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx + write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny + write(6,*) "my_id=",my_id,"global_nx=",global_nx + write(6,*) "my_id=",my_id,"global_nx=",global_ny +#endif + return + end subroutine MPP_LAND_PAR_INI + + subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) +! ### Communicate message on left right direction. + integer NX,NY + real in_out_data(nx,ny),data_r(2,ny) + integer count,size,tag, ierr + integer flag ! 99 replace the boundary, else get the sum. + + if(flag .eq. 99) then ! replace the data + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = ny + call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = ny + call mpi_recv(in_out_data(1,:),size,MPI_REAL, & + left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = ny + tag = 21 + call mpi_send(in_out_data(2,:),size,MPI_REAL, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = ny + call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + else ! get the sum + + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = 2*ny + call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = 2*ny + call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & + HYDRO_COMM_WORLD,mpp_status,ierr) + in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) + in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = 2*ny + tag = 21 + call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = 2*ny + call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + endif ! end if black for flag. + + return + end subroutine MPP_LAND_LR_COM + + subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) +! ### Communicate message on left right direction. + integer NX,NY + real*8 in_out_data(nx,ny),data_r(2,ny) + integer count,size,tag, ierr + integer flag ! 99 replace the boundary, else get the sum. + + if(flag .eq. 99) then ! replace the data + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = ny + call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = ny + call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = ny + tag = 21 + call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = ny + call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + else ! get the sum + + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = 2*ny + call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = 2*ny + call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & + HYDRO_COMM_WORLD,mpp_status,ierr) + in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) + in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = 2*ny + tag = 21 + call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = 2*ny + call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + endif ! end if black for flag. + + return + end subroutine MPP_LAND_LR_COM8 + + + subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) + integer local_nx, local_ny, rt_nx,rt_ny + integer i,status,ierr, tag + integer tmp_nx,tmp_ny +! ### if it is IO node, get the local_size of the x and y direction +! ### for all other tasks. + integer s_r(2) + +! if(my_id .eq. IO_id) then + if(.not. allocated(local_nx_size) ) allocate(local_nx_size(numprocs),stat = status) + if(.not. allocated(local_ny_size) ) allocate(local_ny_size(numprocs),stat = status) + if(.not. allocated(local_rt_nx_size) ) allocate(local_rt_nx_size(numprocs),stat = status) + if(.not. allocated(local_rt_ny_size) ) allocate(local_rt_ny_size(numprocs),stat = status) +! end if + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 1 + call mpi_recv(s_r,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + local_nx_size(i+1) = s_r(1) + local_ny_size(i+1) = s_r(2) + else + local_nx_size(i+1) = local_nx + local_ny_size(i+1) = local_ny + end if + end do + else + tag = 1 + s_r(1) = local_nx + s_r(2) = local_ny + call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 2 + call mpi_recv(s_r,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + local_rt_nx_size(i+1) = s_r(1) + local_rt_ny_size(i+1) = s_r(2) + else + local_rt_nx_size(i+1) = rt_nx + local_rt_ny_size(i+1) = rt_ny + end if + end do + else + tag = 2 + s_r(1) = rt_nx + s_r(2) = rt_ny + call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + + return + end subroutine get_local_size + + + subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) +! ### Communicate message on up down direction. + integer NX,NY + real in_out_data(nx,ny),data_r(nx,2) + integer count,size,tag, status, ierr + integer flag ! 99 replace the boundary , else get the sum of the boundary + + + if(flag .eq. 99) then ! replace the boundary data. + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx + call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx + call mpi_recv(in_out_data(:,1),size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx + call mpi_send(in_out_data(:,2),size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx + call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + else ! flag = 1 + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx*2 + call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx*2 + call mpi_recv(data_r,size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) + in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx*2 + call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx * 2 + call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif ! end of block flag + return + end subroutine MPP_LAND_UB_COM + + subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) +! ### Communicate message on up down direction. + integer NX,NY + real*8 in_out_data(nx,ny),data_r(nx,2) + integer count,size,tag, status, ierr + integer flag ! 99 replace the boundary , else get the sum of the boundary + + + if(flag .eq. 99) then ! replace the boundary data. + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx + call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx + call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx + call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx + call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + else ! flag = 1 + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx*2 + call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx*2 + call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) + in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx*2 + call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx * 2 + call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif ! end of block flag + return + end subroutine MPP_LAND_UB_COM8 + + subroutine calculate_start_p() +! calculate startx and starty + integer :: i,status, ierr, tag + integer :: r_s(2) + integer :: t_nx, t_ny + + if(.not. allocated(starty) ) allocate(starty(numprocs),stat = ierr) + if(.not. allocated(startx) ) allocate(startx(numprocs),stat = ierr) + + local_startx = int(global_nx/left_right_np) * left_right_p+1 + local_starty = int(global_ny/up_down_np) * up_down_p+1 + +!ywold + t_nx = 0 + do i = 1, mod(global_nx,left_right_np) + if(left_right_p .gt. i ) then + t_nx = t_nx + 1 + end if + end do + local_startx = local_startx + t_nx + + t_ny = 0 + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .gt. i) then + t_ny = t_ny + 1 + end if + end do + local_starty = local_starty + t_ny + + + if(left_id .lt. 0) local_startx = 1 + if(down_id .lt. 0) local_starty = 1 + + + if(my_id .eq. IO_id) then + startx(my_id+1) = local_startx + starty(my_id+1) = local_starty + end if + + r_s(1) = local_startx + r_s(2) = local_starty + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ! block receive from other node. + if(i.ne.my_id) then + tag = 1 + call mpi_recv(r_s,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + startx(i+1) = r_s(1) + starty(i+1) = r_s(2) + end if + end do + else + tag = 1 + call mpi_send(r_s,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + +! calculate the routing land start x and y + local_startx_rt = local_startx*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(local_startx_rt.gt.1) local_startx_rt=local_startx_rt - 1 + local_starty_rt = local_starty*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(local_starty_rt.gt.1) local_starty_rt=local_starty_rt - 1 + + local_endx_rt = local_startx_rt + local_rt_nx -1 + local_endy_rt = local_starty_rt + local_rt_ny -1 + + return + end subroutine calculate_start_p + + subroutine calculate_offset_vectors() + !calculate the size and offset vectors needed by scatterv and gatherv + integer :: i, ierr, last_offset + + ! first make sure the arrays have been allocated + if ( .not. allocated(offset_vectors) ) allocate(offset_vectors(numprocs),stat = ierr) + if ( .not. allocated(offset_vectors_rt) ) allocate(offset_vectors_rt(numprocs),stat = ierr) + if ( .not. allocated(size_vectors) ) allocate(size_vectors(numprocs),stat = ierr) + if ( .not. allocated(size_vectors_rt) ) allocate(size_vectors_rt(numprocs),stat = ierr) + + ! calculate the size and offsets using local_nx_size and local_ny_size + last_offset = 0 + do i=1, numprocs + size_vectors(i) = local_ny_size(i) * local_nx_size(i) + offset_vectors(i) = last_offset + last_offset = last_offset + size_vectors(i) + end do + + ! calculate the RT size and offsets using local_rt_nx_size and local_rt_ny_size + last_offset = 0 + do i=1, numprocs + size_vectors_rt(i) = local_rt_ny_size(i) * local_rt_nx_size(i) + offset_vectors_rt(i) = last_offset + last_offset = last_offset + size_vectors_rt(i) + end do + + return + end subroutine calculate_offset_vectors + + subroutine decompose_data_real3d (in_buff,out_buff,klevel) + implicit none + integer:: klevel, k + real,dimension(:,:,:) :: in_buff,out_buff + do k = 1, klevel + call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine decompose_data_real3d + + subroutine decompose_data_real (in_buff,out_buff) + ! usage: all of the cpu call this subroutine. + ! the IO node will distribute the data to rest of the node. + real,intent(in), dimension(:,:) :: in_buff + real,intent(out), dimension(:,:), volatile :: out_buff + real, dimension(:), allocatable :: send_buff + integer tag, i, ii, jj, pos, status, ierr,size + integer ibegin,iend,jbegin,jend + + if(my_id .eq. IO_id) then + + ! allocate the buffer to hold data as required by mpi_scatterv + ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + allocate(send_buff(0: (global_nx*global_ny) -1),stat = ierr) + + ! for each sub region in the global buffer linearize the data and place it in the + ! correct send buffer location + do i = 1, numprocs + ibegin = startx(i) + iend = startx(i)+local_nx_size(i) -1 + jbegin = starty(i) + jend = starty(i)+local_ny_size(i) -1 + + !write (6,*) offset_vectors(i), offset_vectors(i) +size_vectors(i) -1, ibegin, iend, jbegin, jend + + ! we may want use this direct loop to avoid array temps + pos = offset_vectors(i) + do jj = jbegin, jend + do ii = ibegin, iend + send_buff(pos) = in_buff(ii,jj) + pos = pos + 1 + end do + end do + + ! this is much more readable + ! send_buff(offset_vectors(i): offset_vectors(i) + size_vectors(i) - 1) = & + ! reshape(in_buff(ibegin:iend,jbegin:jend), (/size_vectors(i)/) ) + end do + + ! send the to each process size_vector(mpi_rank+1) data elements + ! and store the results in out_buff + call mpi_scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & + out_buff, size_vectors(my_id+1), MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) + + ! remove the send buffer + deallocate(send_buff) + + else + ! other processes only need to make mpi_scatterv call + call mpi_scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & + out_buff, local_nx*local_ny, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) + end if + + return + end subroutine decompose_data_real + + + subroutine decompose_data_int (in_buff,out_buff) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer,dimension(:,:) :: in_buff,out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = local_nx_size(i+1)*local_ny_size(i+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = local_nx*local_ny + call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_data_int + + subroutine write_IO_int(in_buff,out_buff) +! the IO node will receive the data from the rest process. + integer,dimension(:,:):: in_buff, out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_nx*local_ny + tag = 2 + call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_nx_size(i+1)*local_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_int + + subroutine write_IO_char_head(in, out, imageHead) + !! JLM 2015-11-30 + !! for i is image number (starting from 0), + !! this routine writes + !! in(1:imageHead(i+1)) + !! to + !! out( (sum(imageHead(i+1-1))+1) : ((sum(imageHead(i+1-1))+1)+imageHead(i+1)) ) + !! where out is on the IO node. + character(len=*), intent(in), dimension(:) :: in + character(len=*), intent(out), dimension(:) :: out + integer, intent(in), dimension(:) :: imageHead + integer :: tag, i, status, ierr, size + integer :: ibegin,iend,jbegin,jend + integer :: lenSize, theStart, theEnd + tag = 2 + if(my_id .ne. IO_id) then + lenSize = imageHead(my_id+1)*len(in(1)) !! some times necessary for character arrays? + if(lenSize .eq. 0) return + call mpi_send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs-1 + lenSize = imageHead(i+1)*len(in(1)) !! necessary? + if(lenSize .eq. 0) cycle + if(i .eq. 0) then + theStart = 1 + else + theStart = sum(imageHead(1:(i+1-1))) +1 + end if + theEnd = theStart + imageHead(i+1) -1 + if(i .eq. IO_id) then + out(theStart:theEnd) = in(1:imageHead(i+1)) + else + call mpi_recv(out(theStart:theEnd),lenSize,& + MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + end subroutine write_IO_char_head + + + subroutine write_IO_real3d(in_buff,out_buff,klevel) + implicit none +! the IO node will receive the data from the rest process. + integer klevel, k + real,dimension(:,:,:):: in_buff, out_buff + do k = 1, klevel + call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine write_IO_real3d + + subroutine write_IO_real(in_buff,out_buff) +! the IO node will receive the data from the rest process. + real,dimension(:,:):: in_buff, out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_nx*local_ny + tag = 2 + call mpi_send(in_buff,size,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_nx_size(i+1)*local_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_real + +! subroutine write_IO_RT_real_prev(in_buff,out_buff) +! ! the IO node will receive the data from the rest process. +! real,dimension(:,:) :: in_buff, out_buff +! integer tag, i, status, ierr,size +! integer ibegin,iend,jbegin,jend +! if(my_id .ne. IO_id) then +! size = local_rt_nx*local_rt_ny +! tag = 2 +! call mpi_send(in_buff,size,MPI_REAL, IO_id, & +! tag,HYDRO_COMM_WORLD,ierr) +! else +! do i = 0, numprocs - 1 +! ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) +! if(ibegin.gt.1) ibegin=ibegin - 1 +! iend = ibegin + local_rt_nx_size(i+1) -1 +! jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) +! if(jbegin.gt.1) jbegin=jbegin - 1 +! jend = jbegin + local_rt_ny_size(i+1) -1 +! if(i .eq. IO_id) then +! out_buff(ibegin:iend,jbegin:jend) = in_buff +! else +! size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) +! tag = 2 +! call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& +! MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) +! end if +! end do +! end if +! return +! end subroutine write_IO_RT_real_prev + + subroutine write_IO_RT_real (in_buff,out_buff) + ! usage: all of the cpu call this subroutine. + ! the IO node will recieve data from rest of the node. + real,intent(in), dimension(:,:) :: in_buff + real,intent(inout), dimension(:,:) :: out_buff + real, dimension(:), allocatable :: recv_buff + integer tag, i, ii, jj, pos, status, ierr,size + integer ibegin,iend,jbegin,jend,rt_startx,rt_starty + + if(my_id .eq. IO_id) then + + ! allocate the buffer to hold data as required by mpi_scatterv + ! (this will be larger than out_buff due to halo cell overlap) + ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + allocate(recv_buff(0: sum(size_vectors_rt) -1),stat = ierr) + + ! recieve from each process size_vector(mpi_rank+1) data elements + ! and store the results in recv_buffer + call mpi_gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & + recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & + IO_id, HYDRO_COMM_WORLD, ierr) + + ! for each sub region in the recv buffer create a correct shapped array + ! and assign it to the output buffer + do i = 1, numprocs + ibegin = startx(i)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if (ibegin > 1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i) - 1 + jbegin = starty(i)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if (jbegin > 1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i) - 1 + + ! this is much more readable + out_buff(ibegin:iend,jbegin:jend) = & + reshape(recv_buff(offset_vectors_rt(i): offset_vectors_rt(i) + size_vectors_rt(i) - 1), & + (/local_rt_nx_size(i), local_rt_ny_size(i)/) ) + end do + + ! remove the send buffer + deallocate(recv_buff) + + else + ! other processes only need to make mpi_gatherv call + call mpi_gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_REAL, & + recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & + IO_id, HYDRO_COMM_WORLD, ierr) + end if + return + end subroutine write_IO_RT_real + + subroutine write_IO_RT_int (in_buff,out_buff) + ! usage: all of the cpu call this subroutine. + ! the IO node will recieve data from rest of the node. + integer, intent(in), dimension(:,:) :: in_buff + integer, intent(inout), dimension(:,:) :: out_buff + integer, dimension(:), allocatable :: recv_buff + integer tag, i, ii, jj, pos, status, ierr,size + integer ibegin,iend,jbegin,jend,rt_startx,rt_starty + + if(my_id .eq. IO_id) then + + ! allocate the buffer to hold data as required by mpi_scatterv + ! (this will be larger than out_buff due to halo cell overlap) + ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + allocate(recv_buff(0: sum(size_vectors_rt) -1),stat = ierr) + + ! recieve from each process size_vector(mpi_rank+1) data elements + ! and store the results in recv_buffer + call mpi_gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & + recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & + IO_id, HYDRO_COMM_WORLD, ierr) + + ! for each sub region in the recv buffer create a correct shapped array + ! and assign it to the output buffer + do i = 1, numprocs + ibegin = startx(i)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if (ibegin > 1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i) - 1 + jbegin = starty(i)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if (jbegin > 1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i) - 1 + + ! this is much more readable + out_buff(ibegin:iend,jbegin:jend) = & + reshape(recv_buff(offset_vectors_rt(i): offset_vectors_rt(i) + size_vectors_rt(i) - 1), & + (/local_rt_nx_size(i), local_rt_ny_size(i)/) ) + end do + + ! remove the send buffer + deallocate(recv_buff) + + else + ! other processes only need to make mpi_gatherv call + call mpi_gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_INTEGER, & + recv_buff, size_vectors_rt, offset_vectors_rt, MPI_INTEGER, & + IO_id, HYDRO_COMM_WORLD, ierr) + end if + return + end subroutine write_IO_RT_int + +! subroutine write_IO_RT_int (in_buff,out_buff) +! ! the IO node will receive the data from the rest process. +! integer,intent(in),dimension(:,:) :: in_buff +! integer,intent(out),dimension(:,:) :: out_buff +! integer tag, i, status, ierr,size +! integer ibegin,iend,jbegin,jend +! if(my_id .ne. IO_id) then +! size = local_rt_nx*local_rt_ny +! tag = 2 +! call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & +! tag,HYDRO_COMM_WORLD,ierr) +! else +! do i = 0, numprocs - 1 +! ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) +! if(ibegin.gt.1) ibegin=ibegin - 1 +! iend = ibegin + local_rt_nx_size(i+1) -1 +! jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) +! if(jbegin.gt.1) jbegin=jbegin - 1 +! jend = jbegin + local_rt_ny_size(i+1) -1 +! if(i .eq. IO_id) then +! out_buff(ibegin:iend,jbegin:jend) = in_buff +! else +! size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) +! tag = 2 +! call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& +! MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) +! end if +! end do +! end if +! return +! end subroutine write_IO_RT_int + + subroutine write_IO_RT_int8(in_buff,out_buff) + ! the IO node will receive the data from the rest process. + integer(kind=int64),intent(in),dimension(:,:) :: in_buff + integer(kind=int64),intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_rt_nx*local_rt_ny + tag = 2 + call mpi_send(in_buff,size,MPI_INTEGER8, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_RT_int8 + + subroutine mpp_land_bcast_log1(inout) + logical inout + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_log1 + + + subroutine mpp_land_bcast_int(size,inout) + integer size + integer inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int + + subroutine mpp_land_bcast_int8(size,inout) + integer size + integer(kind=int64) inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_INTEGER8, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int8 + + subroutine mpp_land_bcast_int8_1d(inout) + integer len + integer(kind=int64) inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER8, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int8_1d + + subroutine mpp_land_bcast_int1d(inout) + integer len + integer inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int1d + + subroutine mpp_land_bcast_int1d_root(inout, rootId) + integer len + integer inout(:) + integer, intent(in) :: rootId + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int1d_root + + subroutine mpp_land_bcast_int1(inout) + integer inout + integer ierr + call mpi_bcast(inout,1,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int1 + + subroutine mpp_land_bcast_int1_root(inout, rootId) + integer inout + integer ierr + integer, intent(in) :: rootId + call mpi_bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_int1_root + + subroutine mpp_land_bcast_logical(inout) + logical :: inout + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_logical + + subroutine mpp_land_bcast_logical_root(inout, rootId) + logical :: inout + integer, intent(in) :: rootId + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_logical_root + + subroutine mpp_land_bcast_real1(inout) + real inout + integer ierr + call mpi_bcast(inout,1,MPI_REAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_real1 + + subroutine mpp_land_bcast_real1_double(inout) + real*8 inout + integer ierr + call mpi_bcast(inout,1,MPI_REAL8, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_real1_double + + subroutine mpp_land_bcast_real_1d(inout) + integer len + real inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_real, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_real_1d + + subroutine mpp_land_bcast_real_1d_root(inout, rootId) + integer len + real inout(:) + integer, intent(in) :: rootId + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_real,rootId,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_real_1d_root + + subroutine mpp_land_bcast_real8_1d(inout) + integer len + real*8 inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_double, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_real8_1d + + subroutine mpp_land_bcast_real(size1,inout) + integer size1 + ! real inout(size1) + real , dimension(:) :: inout + integer ierr, len + call mpi_bcast(inout,size1,MPI_real, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_real + + subroutine mpp_land_bcast_int2d(inout) + integer length1, k,length2 + integer inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + end do + return + end subroutine mpp_land_bcast_int2d + + subroutine mpp_land_bcast_real2(inout) + integer length1, k,length2 + real inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_real, & + IO_id,HYDRO_COMM_WORLD,ierr) + end do + return + end subroutine mpp_land_bcast_real2 + + subroutine mpp_land_bcast_real3d(inout) + integer j, k, length1, length2, length3 + real inout(:,:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + length3 = size(inout,3) + do k = 1, length3 + do j = 1, length2 + call mpi_bcast(inout(:,j,k), length1, MPI_real, & + IO_id, HYDRO_COMM_WORLD, ierr) + end do + end do + return + end subroutine mpp_land_bcast_real3d + + subroutine mpp_land_bcast_rd(size,inout) + integer size + real*8 inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_REAL8, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_rd + + subroutine mpp_land_bcast_char(size,inout) + integer size + character inout(*) + integer ierr + call mpi_bcast(inout,size,MPI_CHARACTER, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_char + + subroutine mpp_land_bcast_char_root(size,inout,rootId) + integer size + character inout(*) + integer, intent(in) :: rootId + integer ierr + call mpi_bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_char_root + + subroutine mpp_land_bcast_char1d(inout) + character(len=*) :: inout(:) + integer :: lenSize + integer :: ierr + lenSize = size(inout,1)*len(inout) + call mpi_bcast(inout,lenSize,MPI_CHARACTER, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_char1d + + subroutine mpp_land_bcast_char1d_root(inout,rootId) + character(len=*) :: inout(:) + integer, intent(in) :: rootId + integer :: lenSize + integer :: ierr + lenSize = size(inout,1)*len(inout) + call mpi_bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_char1d_root + + subroutine mpp_land_bcast_char1(inout) + integer len + character(len=*) inout + integer ierr + len = LEN_TRIM(inout) + call mpi_bcast(inout,len,MPI_CHARACTER, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine mpp_land_bcast_char1 + + subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + real in_out_data(nx,ny) + + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + + return + end subroutine MPP_LAND_COM_REAL + + subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + real*8 in_out_data(nx,ny) + + call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) + + return + end subroutine MPP_LAND_COM_REAL8 + + subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + integer data(nx,ny) + real in_out_data(nx,ny) + + in_out_data = data + 0.0 + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + data = in_out_data + 0 + + return + end subroutine MPP_LAND_COM_INTEGER + + + subroutine MPP_LAND_COM_INTEGER8(data,NX,NY,flag) + ! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + integer(kind=int64) data(nx,ny) + real in_out_data(nx,ny) + + in_out_data = data + 0.0 + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + data = in_out_data + 0 + + return + end subroutine MPP_LAND_COM_INTEGER8 + + subroutine read_restart_3(unit,nz,out) + integer unit,nz,i + real buf3(global_nx,global_ny,nz),& + out(local_nx,local_ny,3) + if(my_id.eq.IO_id) read(unit) buf3 + do i = 1,nz + call decompose_data_real (buf3(:,:,i),out(:,:,i)) + end do + return + end subroutine read_restart_3 + + subroutine read_restart_2(unit,out) + integer unit,ierr2 + real buf2(global_nx,global_ny),& + out(local_nx,local_ny) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 + call mpp_land_bcast_int1(ierr2) + if(ierr2 .ne. 0) return + + call decompose_data_real (buf2,out) + return + end subroutine read_restart_2 + + subroutine read_restart_rt_2(unit,out) + integer unit,ierr2 + real buf2(global_rt_nx,global_rt_ny),& + out(local_rt_nx,local_rt_ny) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 + call mpp_land_bcast_int1(ierr2) + if(ierr2.ne.0) return + + call decompose_RT_real(buf2,out, & + global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) + return + end subroutine read_restart_rt_2 + + subroutine read_restart_rt_3(unit,nz,out) + integer unit,nz,i,ierr2 + real buf3(global_rt_nx,global_rt_ny,nz),& + out(local_rt_nx,local_rt_ny,3) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3 + call mpp_land_bcast_int1(ierr2) + if(ierr2.ne.0) return + + do i = 1,nz + call decompose_RT_real (buf3(:,:,i),out(:,:,i),& + global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) + end do + return + end subroutine read_restart_rt_3 + + subroutine write_restart_3(unit,nz,in) + integer unit,nz,i + real buf3(global_nx,global_ny,nz),& + in(local_nx,local_ny,nz) + do i = 1,nz + call write_IO_real(in(:,:,i),buf3(:,:,i)) + end do + if(my_id.eq.IO_id) write(unit) buf3 + return + end subroutine write_restart_3 + + subroutine write_restart_2(unit,in) + integer unit + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit) buf2 + return + end subroutine write_restart_2 + + subroutine write_restart_rt_2(unit,in) + integer unit + real buf2(global_rt_nx,global_rt_ny), & + in(local_rt_nx,local_rt_ny) + call write_IO_RT_real(in,buf2) + if(my_id.eq.IO_id) write(unit) buf2 + return + end subroutine write_restart_rt_2 + + subroutine write_restart_rt_3(unit,nz,in) + integer unit,nz,i + real buf3(global_rt_nx,global_rt_ny,nz),& + in(local_rt_nx,local_rt_ny,nz) + do i = 1,nz + call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) + end do + if(my_id.eq.IO_id) write(unit) buf3 + return + end subroutine write_restart_rt_3 + + subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + real,intent(in),dimension(:,:) :: in_buff + real,intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_real + + subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + integer,intent(in),dimension(:,:) :: in_buff + integer,intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_int + + subroutine decompose_RT_int8 (in_buff,out_buff,g_nx,g_ny,nx,ny) + ! usage: all of the cpu call this subroutine. + ! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + integer(kind=int64),intent(in),dimension(:,:) :: in_buff + integer(kind=int64),intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id == IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin > 1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin > 1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id == i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER8, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_INTEGER8,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_int8 + + subroutine getNX_NY(nprocs,nx,ny) + ! calculate the nx and ny based on the total nprocs. + integer nprocs, nx, ny, n + integer i, j, max + + n = global_nx * global_ny + if( nprocs .ge. n ) then + call fatal_error_stop("Error: number of processes greater than number of cells in the land grid") + end if + + max = nprocs + do j = 1, nprocs + if( mod(nprocs,j) .eq. 0 ) then + i = nprocs/j + if( i .le. global_nx ) then + if( abs(i-j) .lt. max) then + if( j .le. global_ny ) then + max = abs(i-j) + nx = i + ny = j + end if + end if + end if + end if + end do + return + end subroutine getNX_NY + + subroutine pack_global_22(in, & + out,k) + integer ix,jx,k,i + real out(global_nx,global_ny,k) + real in(local_nx,local_ny,k) + do i = 1, k + call write_IO_real(in(:,:,i),out(:,:,i)) + enddo + return + end subroutine pack_global_22 + + + subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) + implicit none + integer total_pe + integer info(9,total_pe),AGGFACTRT + integer :: ierr, status + integer i + + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + + if(numprocs .ne. total_pe) then + write(6,*) "FATAL ERROR: In wrf_LAND_set_INIT() - numprocs .ne. total_pe ",numprocs, total_pe + call mpp_land_abort() + endif + + +! ### get the neighbors. -1 means no neighbor. + left_id = info(2,my_id+1) + right_id = info(3,my_id+1) + up_id = info(4,my_id+1) + down_id = info(5,my_id+1) + IO_id = 0 + + allocate(local_nx_size(numprocs),stat = status) + allocate(local_ny_size(numprocs),stat = status) + allocate(local_rt_nx_size(numprocs),stat = status) + allocate(local_rt_ny_size(numprocs),stat = status) + allocate(starty(numprocs),stat = ierr) + allocate(startx(numprocs),stat = ierr) + + i = my_id + 1 + local_nx = info(7,i) - info(6,i) + 1 + local_ny = info(9,i) - info(8,i) + 1 + + global_nx = 0 + global_ny = 0 + do i = 1, numprocs + global_nx = max(global_nx,info(7,i)) + global_ny = max(global_ny,info(9,i)) + enddo + + local_rt_nx = local_nx*AGGFACTRT+2 + local_rt_ny = local_ny*AGGFACTRT+2 + if(left_id.lt.0) local_rt_nx = local_rt_nx -1 + if(right_id.lt.0) local_rt_nx = local_rt_nx -1 + if(up_id.lt.0) local_rt_ny = local_rt_ny -1 + if(down_id.lt.0) local_rt_ny = local_rt_ny -1 + + global_rt_nx = global_nx*AGGFACTRT + global_rt_ny = global_ny*AGGFACTRT + rt_AGGFACTRT = AGGFACTRT + + do i =1,numprocs + local_nx_size(i) = info(7,i) - info(6,i) + 1 + local_ny_size(i) = info(9,i) - info(8,i) + 1 + startx(i) = info(6,i) + starty(i) = info(8,i) + + local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2 + local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2 + if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 + if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 + if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 + if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 + enddo + call calculate_offset_vectors() + + return + end subroutine wrf_LAND_set_INIT + + subroutine getMy_global_id() + integer ierr + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + return + end subroutine getMy_global_id + + subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer(kind=int64) Link_location(ix,jy) + integer i,j, flag + real Link_V(size), tmp_inout(ix,jy) + + tmp_inout = -999 + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_REAL + + + subroutine MPP_CHANNEL_COM_REAL8(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer(kind=int64) Link_location(ix,jy) + integer i,j, flag + real*8 :: Link_V(size), tmp_inout(ix,jy) + + tmp_inout = -999 + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_REAL8(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_REAL8 + + subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer(kind=int64) Link_location(ix,jy) + integer i,j, flag + integer(kind=int64) Link_V(size), tmp_inout(ix,jy) + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + + + +! commu nicate tmp_inout + call MPP_LAND_COM_INTEGER8(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_INT + + + subroutine print_2(unit,in,fm) + integer unit + character(len=*) fm + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit,*) buf2 + return + end subroutine print_2 + + subroutine print_rt_2(unit,in) + integer unit + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit,*) buf2 + return + end subroutine print_rt_2 + + subroutine mpp_land_max_int1(v) + implicit none + integer v, r1, max + integer i, ierr, tag + if(my_id .eq. IO_id) then + max = v + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 101 + call mpi_recv(r1,1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(max <= r1) max = r1 + end if + end do + else + tag = 101 + call mpi_send(v,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_bcast_int1(max) + v = max + return + end subroutine mpp_land_max_int1 + + subroutine mpp_land_max_real1(v) + implicit none + real v, r1, max + integer i, ierr, tag + if(my_id .eq. IO_id) then + max = v + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 101 + call mpi_recv(r1,1,MPI_REAL,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(max <= r1) max = r1 + end if + end do + else + tag = 101 + call mpi_send(v,1,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_bcast_real1(max) + v = max + return + end subroutine mpp_land_max_real1 + + subroutine mpp_same_int1(v) + implicit none + integer v,r1 + integer i, ierr, tag + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 109 + call mpi_recv(r1,1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(v .ne. r1) v = -99 + end if + end do + else + tag = 109 + call mpi_send(v,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_bcast_int1(v) + end subroutine mpp_same_int1 + + + + subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks) + real recv(nlinks), v(nlinks) + ! real g_v(gnlinks), tmp_v(gnlinks) + integer i, ierr, tag, k + integer length, node, message_len + integer,allocatable,dimension(:) :: tmp_map + real, allocatable, dimension(:) :: tmp_v + real, dimension(:) :: g_v + + if(my_id .eq. io_id) then + allocate(tmp_map(gnlinks)) + allocate(tmp_v(gnlinks)) + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + else + allocate(tmp_map(1)) + allocate(tmp_v(1)) + endif + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 119 + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + node = tmp_map(k) + if(node .gt. 0) then + g_v(node) = tmp_v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=", node +#endif + endif + enddo + else + do k = 1,nlinks + node = map_l2g(k) + if(node .gt. 0) then + g_v(node) = v(k) + else +#ifdef HYDRO_D + write(6,*) "local Maping infor k=",k," node=",node +#endif + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + + end if + if(allocated(tmp_map)) deallocate(tmp_map) + if(allocated(tmp_v)) deallocate(tmp_v) + end subroutine write_chanel_real + + subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks) + integer :: recv(nlinks), v(nlinks) + integer, allocatable, dimension(:) :: tmp_map , tmp_v + integer, dimension(:) :: g_v + integer i, ierr, tag, k + integer length, node, message_len + + if(my_id .eq. io_id) then + allocate(tmp_map(gnlinks)) + allocate(tmp_v(gnlinks)) + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + else + allocate(tmp_map(1)) + allocate(tmp_v(1)) + endif + + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 119 + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + if(tmp_map(k) .gt. 0) then + node = tmp_map(k) + g_v(node) = tmp_v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=",tmp_v(k) +#endif + endif + enddo + else + do k = 1,nlinks + if(map_l2g(k) .gt. 0) then + node = map_l2g(k) + g_v(node) = v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=",map_l2g(k) +#endif + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + if(allocated(tmp_map)) deallocate(tmp_map) + if(allocated(tmp_v)) deallocate(tmp_v) + end subroutine write_chanel_int + + subroutine write_chanel_int8(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks) + integer(kind=int64) :: recv(nlinks), v(nlinks) + integer(kind=int64), allocatable, dimension(:) :: tmp_v + integer, allocatable, dimension(:) :: tmp_map + integer(kind=int64), dimension(:) :: g_v + integer i, ierr, tag, k + integer length, node, message_len + + if(my_id .eq. io_id) then + allocate(tmp_map(gnlinks)) + allocate(tmp_v(gnlinks)) + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + else + allocate(tmp_map(1)) + allocate(tmp_v(1)) + endif + + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 119 + call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER8,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + if(tmp_map(k) .gt. 0) then + node = tmp_map(k) + g_v(node) = tmp_v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=",tmp_v(k) +#endif + endif + enddo + else + do k = 1,nlinks + if(map_l2g(k) .gt. 0) then + node = map_l2g(k) + g_v(node) = v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=",map_l2g(k) +#endif + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_INTEGER8,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + if(allocated(tmp_map)) deallocate(tmp_map) + if(allocated(tmp_v)) deallocate(tmp_v) + end subroutine write_chanel_int8 + + + subroutine write_lake_real(v,nodelist_in,nlakes) + implicit none + real recv(nlakes), v(nlakes) + integer nodelist(nlakes), nlakes, nodelist_in(nlakes) + integer i, ierr, tag, k + integer length, node + + nodelist = nodelist_in + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 129 + call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 139 + call mpi_recv(recv(:),nlakes,MPI_REAL,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,nlakes + if(nodelist(k) .gt. -99) then + node = nodelist(k) + v(node) = recv(node) + endif + enddo + end if + end do + else + tag = 129 + call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 139 + call mpi_send(v,nlakes,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + end subroutine write_lake_real + + + subroutine write_lake_char(v,nodelist_in,nlakes) + implicit none + character(len=256) recv(nlakes), v(nlakes) + integer nodelist(nlakes), nlakes, nodelist_in(nlakes) + integer i, ierr, tag, k, in_len + integer length, node + + in_len = size(v, 1)*len(v) + + nodelist = nodelist_in + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 129 + call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 139 + call mpi_recv(recv(:),in_len,MPI_CHARACTER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,nlakes + if(nodelist(k) .gt. -99) then + node = nodelist(k) + v(node) = recv(node) + endif + enddo + end if + end do + else + tag = 129 + call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 139 + call mpi_send(v,in_len,MPI_CHARACTER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + end subroutine write_lake_char + + + subroutine read_rst_crt_r(unit,out,size) + implicit none + integer unit, size, ierr,ierr2 + real out(size),out1(size) + if(my_id.eq.IO_id) then + read(unit,IOSTAT=ierr2,end=99) out1 + if(ierr2.eq.0) out=out1 + endif +99 continue + call mpp_land_bcast_int1(ierr2) + if(ierr2 .ne. 0) return + call mpi_bcast(out,size,MPI_REAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine read_rst_crt_r + + subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) + integer :: unit,gnlinks,nlinks,map_l2g(nlinks) + real cd(nlinks) + real g_cd (gnlinks) + call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) + write(unit) g_cd + return + end subroutine write_rst_crt_r + + subroutine sum_int1d(vin,nsize) + implicit none + integer nsize,i,j,tag,ierr + integer, dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + vin(:) = vin(:) + recv(:) + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vin) + return + end subroutine sum_int1d + + subroutine combine_int1d(vin,nsize, flag) + implicit none + integer nsize,i,j,tag,ierr, flag, k + integer, dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(recv(k) .ne. flag) then + vin(k) = recv(k) + endif + enddo + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vin) + return + end subroutine combine_int1d + + subroutine combine_int8_1d(vin,nsize, flag) + implicit none + integer nsize,i,j,tag,ierr, flag, k + integer(kind=int64), dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER8,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(recv(k) .ne. flag) then + vin(k) = recv(k) + endif + enddo + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER8,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int8_1d(vin) + return + end subroutine combine_int8_1d + + subroutine sum_real1d(vin,nsize) + implicit none + integer :: nsize + real,dimension(nsize) :: vin + real*8,dimension(nsize) :: vin8 + vin8=vin + call sum_real8(vin8,nsize) + vin=vin8 + end subroutine sum_real1d + + subroutine sum_real8(vin,nsize) + implicit none + integer nsize,i,j,tag,ierr + real*8, dimension(nsize):: vin,recv + real, dimension(nsize):: v + tag = 319 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + vin(:) = vin(:) + recv(:) + endif + end do + v = vin + else + call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_real(nsize,v) + vin = v + return + end subroutine sum_real8 + +! subroutine get_globalDim(ix,g_ix) +! implicit none +! integer ix,g_ix, ierr +! +! if ( my_id .eq. IO_id ) then +! g_ix = ix +! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & +! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) +! else +! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & +! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) +! endif +! call mpp_land_bcast_int1(g_ix) +! +! return +! +! end subroutine get_globalDim + + subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) + integer sg, s,e, size, s_in, e_in + integer index_s(2) + integer tag, ierr,i +! s: start index, e: end index + real vl(e_in-s_in+1), vg(sg) + s = s_in + e = e_in + + if(my_id .eq. IO_id) then + vg(s:e) = vl + end if + + index_s(1) = s + index_s(2) = e + size = e - s + 1 + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 202 + call mpi_recv(index_s,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + tag = 203 + e = index_s(2) + s = index_s(1) + size = e - s + 1 + call mpi_recv(vg(s:e),size,MPI_REAL, & + i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + end do + else + tag = 202 + call mpi_send(index_s,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + + tag = 203 + call mpi_send(vl,size,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + + return + end subroutine gather_1d_real_tmp + + subroutine sum_real1(inout) + implicit none + real:: inout, send + integer :: ierr + send = inout + CALL MPI_ALLREDUCE(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) + end subroutine sum_real1 + + subroutine sum_double(inout) + implicit none + real*8:: inout, send + integer :: ierr + send = inout + !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) + CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) + end subroutine sum_double + + subroutine mpp_chrt_nlinks_collect(nlinks) + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + allocate(mpp_nlinks(numprocs),stat = status) + tag = 138 + mpp_nlinks = 0 + if(my_id .eq. IO_id) then + do i = 0,numprocs -1 + if(i .ne. my_id) then + call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + else + mpp_nlinks(i+1) = 0 + end if + end do + else + call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + + + end subroutine mpp_chrt_nlinks_collect + + subroutine getLocalXY(ix,jx,startx,starty,endx,endy) +!!! this is for NoahMP only + implicit none + integer:: ix,jx,startx,starty,endx,endy + startx = local_startx + starty = local_starty + endx = startx + ix -1 + endy = starty + jx -1 + end subroutine getLocalXY + + subroutine check_landreal1(unit, inVar) + implicit none + integer :: unit + real :: inVar + if(my_id .eq. IO_id) then + write(unit,*) inVar + call flush(unit) + endif + end subroutine check_landreal1 + + subroutine check_landreal1d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:) + if(my_id .eq. IO_id) then + write(unit,*) inVar + call flush(unit) + endif + end subroutine check_landreal1d + subroutine check_landreal2d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:,:) + real :: g_var(global_nx,global_ny) + call write_io_real(inVar,g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + call flush(unit) + endif + end subroutine check_landreal2d + + subroutine check_landreal3d(unit, inVar) + implicit none + integer :: unit, k, klevel + real :: inVar(:,:,:) + real :: g_var(global_nx,global_ny) + klevel = size(inVar,2) + do k = 1, klevel + call write_io_real(inVar(:,k,:),g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + call flush(unit) + endif + end do + end subroutine check_landreal3d + + subroutine mpp_collect_1d_int(nlinks,vinout) + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + integer, dimension(nlinks) :: vinout + integer, dimension(nlinks) :: buf + tag = 139 + if(my_id .eq. IO_id) then + do i = 0,numprocs -1 + if(i .ne. my_id) then + call mpi_recv(buf,nlinks,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + vinout = vinout + buf + end if + end do + else + call mpi_send(vinout,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vinout) + + end subroutine mpp_collect_1d_int + + subroutine mpp_collect_1d_int_mem(nlinks,vinout) + ! consider the memory and big size data transport + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + integer, dimension(nlinks) :: vinout, tmpIn + integer, dimension(nlinks) :: buf + integer :: lsize, k,m + integer, allocatable, dimension(:) :: tmpBuf + + if(my_id .eq. IO_id) then + allocate (tmpBuf(nlinks)) + do i = 0,numprocs -1 + if(i .ne. my_id) then + tag = 120 + call mpi_recv(lsize,1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(lsize .gt. 0) then + tag = 121 + call mpi_recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, lsize + m = tmpBuf(k) + vinout(m) = 1 + end do + endif + end if + end do + if(allocated(tmpBuf)) deallocate(tmpBuf) + else + lsize = 0 + do k = 1, nlinks + if(vinout(k) .gt. 0) then + lsize = lsize + 1 + tmpIn(lsize) = k + end if + end do + tag = 120 + call mpi_send(lsize,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + if(lsize .gt. 0) then + tag = 121 + call mpi_send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call mpp_land_bcast_int1d(vinout) + + end subroutine mpp_collect_1d_int_mem + + subroutine updateLake_seqInt(in,nsize,in0) + implicit none + integer :: nsize + integer, dimension(nsize) :: in + integer, dimension(nsize) :: tmp + integer, dimension(:) :: in0 + integer tag, i, status, ierr, k + if(nsize .le. 0) return + + tag = 29 + if(my_id .ne. IO_id) then + call mpi_send(in,nsize,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + call mpi_recv(tmp,nsize,& + MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(in0(k) .ne. tmp(k)) in(k) = tmp(k) + end do + end if + end do + end if + call mpp_land_bcast_int1d(in) + + end subroutine updateLake_seqInt + + subroutine updateLake_seqInt8(in,nsize,in0) + implicit none + integer :: nsize + integer(kind=int64), dimension(nsize) :: in + integer(kind=int64), dimension(nsize) :: tmp + integer(kind=int64), dimension(:) :: in0 + integer tag, i, status, ierr, k + if(nsize .le. 0) return + + tag = 29 + if(my_id .ne. IO_id) then + call mpi_send(in,nsize,MPI_INTEGER8, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + call mpi_recv(tmp,nsize,& + MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(in0(k) .ne. tmp(k)) in(k) = tmp(k) + end do + end if + end do + end if + call mpp_land_bcast_int8_1d(in) + + end subroutine updateLake_seqInt8 + + + subroutine updateLake_seq(in,nsize,in0) + implicit none + + integer :: nsize + real, dimension(:), intent(inout), asynchronous :: in + real, dimension(:), intent(in) :: in0 + + real, dimension(nsize) :: tmp + real, dimension(:), allocatable, asynchronous :: prev + real, dimension(:), allocatable :: adjustment + logical new + integer tag, i, status, ierr, k + + if (nsize .le. 0) return + + allocate(adjustment(nsize)) + allocate(prev(nsize)) + + if (my_id == IO_id) prev = in0 + call mpi_bcast(prev, nsize, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) + + if (my_id == IO_id) then + adjustment = in + else + adjustment = in - prev + end if + + call mpi_allreduce(adjustment, in, nsize, MPI_REAL, MPI_SUM, HYDRO_COMM_WORLD, ierr) ! TODO: check ierr! + + deallocate(adjustment) + deallocate(prev) + + end subroutine updateLake_seq + + + subroutine updateLake_seq_char(in,nsize,in0) + implicit none + integer :: nsize + character(len=256), dimension(nsize) :: in + character(len=256), dimension(nsize) :: tmp + character(len=256), dimension(:) :: in0 + integer tag, i, status, ierr, k, in_len + if(nsize .le. 0) return + + in_len = size(in, 1)*len(in) + + tag = 29 + if(my_id .ne. IO_id) then + call mpi_send(in,in_len,MPI_CHARACTER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + call mpi_recv(tmp,in_len,& + MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(in0(k) .ne. tmp(k)) in(k) = tmp(k) + end do + end if + end do + end if + call mpp_land_bcast_char1d(in) + + end subroutine updateLake_seq_char + + + subroutine updateLake_grid(in,nsize,lake_index) + implicit none + integer :: nsize + real, dimension(nsize) :: in + integer, dimension(nsize) :: lake_index + real, dimension(nsize) :: tmp + integer tag, i, status, ierr, k + if(nsize .le. 0) return + + if(my_id .ne. IO_id) then + tag = 29 + call mpi_send(in,nsize,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 30 + call mpi_send(lake_index,nsize,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + tag = 29 + call mpi_recv(tmp,nsize,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 30 + call mpi_recv(lake_index,nsize,& + MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(lake_index(k) .gt. 0) in(k) = tmp(k) + end do + end if + end do + end if + call mpp_land_bcast_real_1d(in) + + end subroutine updateLake_grid + + +!subroutine match1dLake: +!global lake. Find the same lake and mark as flag +! default of win is 0 + subroutine match1dLake(vin,nsize,flag) + implicit none + integer nsize,i,j,tag,ierr, flag, k + integer, dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(recv(k) .eq. flag) vin(k) = flag + if(vin(k) .ne. flag) then + if(vin(k) .gt. 0 .and. recv(k) .gt. 0) then + vin(k) = flag + else + if(recv(k) .gt. 0) vin(k) = recv(k) + endif + endif + end do + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vin) + return + end subroutine match1dLake + + subroutine mpp_land_abort() + implicit none + integer ierr + CALL MPI_ABORT(HYDRO_COMM_WORLD,1,IERR) + end subroutine mpp_land_abort ! mpp_land_abort + + subroutine mpp_land_sync() + implicit none + integer ierr + call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + if(ierr .ne. 0) call mpp_land_abort() + return + end subroutine mpp_land_sync ! mpp_land_sync + + subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) + implicit none + real, intent(inout) :: scalar + integer, intent(in) :: fromImage, toImage + integer:: ierr, tag + tag=2 + if(my_id .eq. fromImage) & + call mpi_send(scalar, 1, MPI_REAL, & + toImage, tag, HYDRO_COMM_WORLD, ierr) + if(my_id .eq. toImage) & + call mpi_recv(scalar, 1, MPI_REAL, & + fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) + end subroutine mpp_comm_scalar_real + + subroutine mpp_comm_scalar_char(scalar, fromImage, toImage) + implicit none + character(len=*), intent(inout) :: scalar + integer, intent(in) :: fromImage, toImage + integer:: ierr, tag, length + tag=2 + length=len(scalar) + if(my_id .eq. fromImage) & + call mpi_send(scalar, length, MPI_CHARACTER, & + toImage, tag, HYDRO_COMM_WORLD, ierr) + if(my_id .eq. toImage) & + call mpi_recv(scalar, length, MPI_CHARACTER, & + fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) + end subroutine mpp_comm_scalar_char + + + subroutine mpp_comm_1d_real(vector, fromImage, toImage) + implicit none + real, dimension(:), intent(inout) :: vector + integer, intent(in) :: fromImage, toImage + integer:: ierr, tag + integer:: my_id, numprocs + tag=2 + call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) + call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) + if(numprocs > 1) then + if(my_id .eq. fromImage) & + call mpi_send(vector, size(vector), MPI_REAL, & + toImage, tag, HYDRO_COMM_WORLD, ierr) + if(my_id .eq. toImage) & + call mpi_recv(vector, size(vector), MPI_REAL, & + fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) + endif + end subroutine mpp_comm_1d_real + + + subroutine mpp_comm_1d_char(vector, fromImage, toImage) + implicit none + character(len=*), dimension(:), intent(inout) :: vector + integer, intent(in) :: fromImage, toImage + integer:: ierr, tag, totalLength + integer:: my_id,numprocs + tag=2 + call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) + call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) + totalLength=len(vector(1))*size(vector,1) + if(numprocs > 1) then + if(my_id .eq. fromImage) & + call mpi_send(vector, totalLength, MPI_CHARACTER, & + toImage, tag, HYDRO_COMM_WORLD, ierr) + if(my_id .eq. toImage) & + call mpi_recv(vector, totalLength, MPI_CHARACTER, & + fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) + endif + end subroutine mpp_comm_1d_char + + +END MODULE MODULE_MPP_LAND diff --git a/hydro/OrchestratorLayer/CMakeLists.txt b/hydro/OrchestratorLayer/CMakeLists.txt new file mode 100644 index 0000000000..c0e1f4ad9d --- /dev/null +++ b/hydro/OrchestratorLayer/CMakeLists.txt @@ -0,0 +1,16 @@ +# build the orchestrator static library +add_library(hydro_orchestrator STATIC + config.F90 + io_manager.F90 + orchestrator.F90 +) + +add_dependencies(hydro_orchestrator + hydro_netcdf_layer + hydro_utils +) + +target_link_libraries(hydro_orchestrator PRIVATE + hydro_netcdf_layer + hydro_utils +) diff --git a/hydro/OrchestratorLayer/Makefile b/hydro/OrchestratorLayer/Makefile index 0f744825a4..7484474dca 100644 --- a/hydro/OrchestratorLayer/Makefile +++ b/hydro/OrchestratorLayer/Makefile @@ -1,7 +1,7 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .f90 +.SUFFIXES: .o .F90 include ../macros @@ -20,10 +20,10 @@ all: $(OBJS) # @echo "" # cp *.mod ../mod -.f90.o: +.F90.o: @echo "Orchestrator Makefile:" # $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f - $(COMPILER90) $(CPPINVOKE) -o $(@) $(CPPFLAGS) $(FPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).f90 + $(COMPILER90) $(CPPINVOKE) -o $(@) $(CPPFLAGS) $(FPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).F90 # $(RMD) $(*).f @echo "" ar -r ../lib/libHYDRO.a $(@) @@ -36,5 +36,5 @@ io_manager.o: ../IO/netcdf_layer.o orchestrator.o: io_manager.o config.o -clean: +clean: rm -f *.o *.mod *.stb *~ *.f diff --git a/hydro/OrchestratorLayer/config.f90 b/hydro/OrchestratorLayer/config.F90 similarity index 99% rename from hydro/OrchestratorLayer/config.f90 rename to hydro/OrchestratorLayer/config.F90 index 6261535cad..8188579658 100644 --- a/hydro/OrchestratorLayer/config.f90 +++ b/hydro/OrchestratorLayer/config.F90 @@ -645,10 +645,7 @@ subroutine init_namelist_rt_field(did) if(maxAgePairsBiasPersist .eq. -99999) maxAgePairsBiasPersist = -1*nLastObs #endif close(12) - - if (sys_cpl == 1) then - call read_crocus_namelist(crocus_opts) - endif + if (sys_cpl == 1) call read_crocus_namelist(crocus_opts) ! #ifdef MPP_LAND ! endif ! #endif @@ -751,11 +748,11 @@ subroutine init_namelist_rt_field(did) print*, "reset DTRT_TER=nlst(did)%DT " DTRT_TER=nlst(did)%DT endif - if(nlst(did)%DT/DTRT_TER .ne. real(int(nlst(did)%DT) / int(DTRT_TER)) ) then + if (modulo(nlst(did)%DT, DTRT_TER) /= 0) then print*, "nlst(did)%DT, DTRT_TER = ",nlst(did)%DT, DTRT_TER call hydro_stop("module_namelist: DT not a multiple of DTRT_TER") endif - if(nlst(did)%DT/DTRT_CH .ne. real(int(nlst(did)%DT) / int(DTRT_CH)) ) then + if (modulo(nlst(did)%DT, DTRT_CH) /= 0) then print*, "nlst(did)%DT, DTRT_CH = ",nlst(did)%DT, DTRT_CH call hydro_stop("module_namelist: DT not a multiple of DTRT_CH") endif @@ -1087,7 +1084,7 @@ subroutine read_crocus_namelist(opt, f_in) type(crocus_options), intent(OUT) :: opt integer, intent(IN), optional :: f_in character(len=15) :: filename = "namelist.hrldas" - logical :: f_exists, f_opened + logical :: f_exists integer :: crocus_opt, act_lev integer :: ierr, f_local namelist /CROCUS_nlist/ & @@ -1095,14 +1092,14 @@ subroutine read_crocus_namelist(opt, f_in) ! check if file is opened if (present(f_in)) then - rewind(30) + rewind(f_in) read(f_in, NML=CROCUS_nlist, iostat=ierr) else ! check that file exists inquire(file=filename, exist=f_exists) if (f_exists .eqv. .false.) & call hydro_stop (" FATAL ERROR: namelist.hrldas does not exist") - open(f_local, file=filename, form="FORMATTED", iostat=ierr) + open(newunit=f_local, file=filename, form="FORMATTED", iostat=ierr) read(f_local, NML=CROCUS_nlist, iostat=ierr) close(f_local) end if diff --git a/hydro/OrchestratorLayer/io_manager.f90 b/hydro/OrchestratorLayer/io_manager.F90 similarity index 98% rename from hydro/OrchestratorLayer/io_manager.f90 rename to hydro/OrchestratorLayer/io_manager.F90 index 349c0cfe70..2d99c9dde4 100644 --- a/hydro/OrchestratorLayer/io_manager.f90 +++ b/hydro/OrchestratorLayer/io_manager.F90 @@ -1,7 +1,7 @@ module io_manager_base use netcdf_layer_base implicit none - + type :: IOManager_ logical :: parallel = .false. class(NetCDF_layer_),allocatable :: netcdf_layer @@ -11,7 +11,7 @@ module io_manager_base interface IOManager_ module procedure IOManager_init end interface IOManager_ - + contains type(IOManager_) function IOManager_init(parallel) @@ -32,7 +32,7 @@ type(IOManager_) function IOManager_init(parallel) allocate(NetCDF_parallel_ :: IOManager_init%netcdf_layer) IOManager_init%netcdf_layer%open_file => nf90_open end if - + end function IOManager_init - + end module io_manager_base diff --git a/hydro/OrchestratorLayer/orchestrator.f90 b/hydro/OrchestratorLayer/orchestrator.F90 similarity index 94% rename from hydro/OrchestratorLayer/orchestrator.f90 rename to hydro/OrchestratorLayer/orchestrator.F90 index f622cc49b2..31be2852da 100644 --- a/hydro/OrchestratorLayer/orchestrator.f90 +++ b/hydro/OrchestratorLayer/orchestrator.F90 @@ -6,7 +6,7 @@ module orchestrator_base ! interface orchestrator_ ! procedure orchestrator_init ! end interface orchestrator_ - + type orchestrator_ !class(FluxAggregator_) :: flux_aggregator @@ -17,19 +17,19 @@ module orchestrator_base !class(SpatialObject_) :: spatial_object contains - + procedure, public, pass(self) :: init => orchestrator_init end type orchestrator_ type(orchestrator_), save :: orchestrator - + contains !We may want routines to access the various components subroutine orchestrator_init(self) - class (orchestrator_) :: self + class (orchestrator_) :: self self%config = Configuration_() @@ -37,7 +37,7 @@ subroutine orchestrator_init(self) ! Read configuration and decide how to assemble the various components ! Assuming IO_Manager_serial_ selected self%IO_manager = IOManager_() - + end subroutine orchestrator_init end module orchestrator_base diff --git a/hydro/Routing/CMakeLists.txt b/hydro/Routing/CMakeLists.txt new file mode 100644 index 0000000000..87a4b337db --- /dev/null +++ b/hydro/Routing/CMakeLists.txt @@ -0,0 +1,38 @@ +add_library(hydro_routing STATIC + module_UDMAP.F90 + module_channel_routing.F90 + module_date_utilities_rt.F90 + module_GW_baseflow.F90 + module_gw_gw2d.F90 + module_HYDRO_io.F90 + module_HYDRO_utils.F90 + module_lsm_forcing.F90 + module_noah_chan_param_init_rt.F90 + module_NWM_io_dict.F90 + module_NWM_io.F90 + module_reservoir_routing.F90 + module_RT.F90 + Noah_distr_routing.F90 + Noah_distr_routing_overland.F90 + Noah_distr_routing_subsurface.F90 +) + +target_link_libraries(hydro_routing + MPI::MPI_Fortran + hydro_mpp + hydro_utils + hydro_orchestrator + hydro_routing_overland + hydro_routing_subsurface + hydro_routing_reservoirs + hydro_routing_reservoirs_levelpool + hydro_routing_reservoirs_hybrid + hydro_data_rec + hydro_routing_reservoirs_rfc +) + +target_include_directories(hydro_routing + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) diff --git a/hydro/Routing/Makefile b/hydro/Routing/Makefile index 9360cbb2d1..65d6ca4575 100644 --- a/hydro/Routing/Makefile +++ b/hydro/Routing/Makefile @@ -1,7 +1,7 @@ # Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros @@ -26,17 +26,17 @@ OBJS = \ all: $(OBJS) -#module_RT.o: module_RT.F +#module_RT.o: module_RT.F90 # @echo "" -# $(CPP) $(CPPFLAGS) $(*).F > $(*).f -# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f -# $(RMD) $(*).f +# $(CPP) $(CPPFLAGS) $(*).F90 > $(*).f90 +# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f90 +# $(RMD) $(*).f90 # @echo "" # cp *.mod ../mod -.F.o: +.F90.o: @echo "Routing Makefile:" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).F90 @echo "" ar -r ../lib/libHYDRO.a $(@) cp *.mod ../mod diff --git a/hydro/Routing/Noah_distr_routing.F b/hydro/Routing/Noah_distr_routing.F90 similarity index 99% rename from hydro/Routing/Noah_distr_routing.F rename to hydro/Routing/Noah_distr_routing.F90 index 30f8d97656..46631cd67b 100644 --- a/hydro/Routing/Noah_distr_routing.F +++ b/hydro/Routing/Noah_distr_routing.F90 @@ -1337,4 +1337,3 @@ subroutine time_seconds(i3) time_array(7) + 0.001 * time_array(8) return end subroutine time_seconds - diff --git a/hydro/Routing/Noah_distr_routing_overland.F b/hydro/Routing/Noah_distr_routing_overland.F90 similarity index 100% rename from hydro/Routing/Noah_distr_routing_overland.F rename to hydro/Routing/Noah_distr_routing_overland.F90 diff --git a/hydro/Routing/Noah_distr_routing_subsurface.F b/hydro/Routing/Noah_distr_routing_subsurface.F90 similarity index 100% rename from hydro/Routing/Noah_distr_routing_subsurface.F rename to hydro/Routing/Noah_distr_routing_subsurface.F90 diff --git a/hydro/Routing/Overland/CMakeLists.txt b/hydro/Routing/Overland/CMakeLists.txt new file mode 100644 index 0000000000..790495cff4 --- /dev/null +++ b/hydro/Routing/Overland/CMakeLists.txt @@ -0,0 +1,7 @@ +add_library(hydro_routing_overland STATIC + module_overland_control.F90 + module_overland_mass_balance.F90 + module_overland_streams_and_lakes.F90 + module_overland_routing_properties.F90 + module_overland.F90 +) diff --git a/hydro/Routing/Overland/Makefile b/hydro/Routing/Overland/Makefile index 5199155159..bed4061599 100644 --- a/hydro/Routing/Overland/Makefile +++ b/hydro/Routing/Overland/Makefile @@ -17,12 +17,12 @@ FLFLAGS= all: mod mod: - #Build each sub module then build the module that depends on all sub modules - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_control.F - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_streams_and_lakes.F - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_routing_properties.F - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_mass_balance.F - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland.F + #Build each sub module then build the module that depends on all sub modules + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_control.F90 + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_streams_and_lakes.F90 + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_routing_properties.F90 + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland_mass_balance.F90 + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) $(F90FLAGS) $(LDFLAGS) $(MODFLAGS) -I$(NETCDFINC) module_overland.F90 ar -r ../../lib/libHYDRO.a module_overland_control.o ar -r ../../lib/libHYDRO.a module_overland_streams_and_lakes.o ar -r ../../lib/libHYDRO.a module_overland_routing_properties.o @@ -31,7 +31,7 @@ mod: cp *.mod ../../mod test: - $(COMPILER90) $(FFLAGS) overland_tests.F + $(COMPILER90) $(FFLAGS) overland_tests.F90 $(COMPILER90) -o overland_tests \ module_overland_control.o \ module_overland_streams_and_lakes.o \ @@ -40,6 +40,6 @@ test: module_overland.o \ overland_tests.o clean: - rm -f *.o + rm -f *.o rm -f *.mod rm -f overland_tests diff --git a/hydro/Routing/Overland/module_overland.F b/hydro/Routing/Overland/module_overland.F90 similarity index 100% rename from hydro/Routing/Overland/module_overland.F rename to hydro/Routing/Overland/module_overland.F90 diff --git a/hydro/Routing/Overland/module_overland_control.F b/hydro/Routing/Overland/module_overland_control.F90 similarity index 100% rename from hydro/Routing/Overland/module_overland_control.F rename to hydro/Routing/Overland/module_overland_control.F90 diff --git a/hydro/Routing/Overland/module_overland_mass_balance.F b/hydro/Routing/Overland/module_overland_mass_balance.F90 similarity index 98% rename from hydro/Routing/Overland/module_overland_mass_balance.F rename to hydro/Routing/Overland/module_overland_mass_balance.F90 index 1f2b6c64aa..06a8ccb3e8 100644 --- a/hydro/Routing/Overland/module_overland_mass_balance.F +++ b/hydro/Routing/Overland/module_overland_mass_balance.F90 @@ -11,12 +11,12 @@ module overland_mass_balance ! holds variables used for mass balance type overland_mass_balance_struct ! mass balance - + ! replaced with accumulated_change_in_soil_moisture !real(kind=8) :: dsmctot ! total difference in soil moisture each timestep real(kind=8) :: accumulated_change_in_soil_moisture - + ! replaced with pre_soil_mosture_content !real(kind=8) :: smctot1 ! NEED VARIABLE INFO ! Pre time step soil moisture content accumulator (mm) TODO verify unit @@ -29,14 +29,14 @@ module overland_mass_balance ! replaced with pre_infiltration_excess !real(kind=8) :: suminfxs1 ! NEED VARIABLE INFO - + ! Pre time step infiltration excess accumulator (mm) TODO verify unit ! FIX ME -- this variable was declared as real(kind=8) as mis match with parameter specification ! in Noah_distributed_routing.F:OverlandRouting matched it with parameter specified as real(kind=4) ! this caused an implicit cast to single percision float which was required as the value was then used ! in the sum_real mpi call which required single percision. Does this variable need to be a double? real :: pre_infiltration_excess - + ! replaced with post_infiltration_excess !real(kind=8) :: suminfxsrt ! NEED VARIABLE INFO ! Post time step infiltration excess accumulator (mm) TODO verify unit @@ -45,7 +45,7 @@ module overland_mass_balance ! this caused an implicit cast to single percision float which was required as the value was then used ! in the sum_real mpi call which required single percision. Does this variable need to be a double? real :: post_infiltration_excess - + contains procedure :: init => overland_mass_balance_init procedure :: destroy => overland_mass_balance_destroy diff --git a/hydro/Routing/Overland/module_overland_routing_properties.F b/hydro/Routing/Overland/module_overland_routing_properties.F90 similarity index 100% rename from hydro/Routing/Overland/module_overland_routing_properties.F rename to hydro/Routing/Overland/module_overland_routing_properties.F90 diff --git a/hydro/Routing/Overland/module_overland_streams_and_lakes.F b/hydro/Routing/Overland/module_overland_streams_and_lakes.F90 similarity index 100% rename from hydro/Routing/Overland/module_overland_streams_and_lakes.F rename to hydro/Routing/Overland/module_overland_streams_and_lakes.F90 diff --git a/hydro/Routing/Overland/overland_tests.F b/hydro/Routing/Overland/overland_tests.F90 similarity index 100% rename from hydro/Routing/Overland/overland_tests.F rename to hydro/Routing/Overland/overland_tests.F90 diff --git a/hydro/Routing/Reservoirs/CMakeLists.txt b/hydro/Routing/Reservoirs/CMakeLists.txt new file mode 100644 index 0000000000..2197060090 --- /dev/null +++ b/hydro/Routing/Reservoirs/CMakeLists.txt @@ -0,0 +1,18 @@ +add_library(hydro_routing_reservoirs STATIC + module_reservoir.F90 + module_reservoir_read_timeslice_data.F90 + module_reservoir_read_rfc_time_series_data.F90 + module_reservoir_utilities.F90 +) + +target_include_directories(hydro_routing_reservoirs + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) + +add_subdirectory("Level_Pool") +add_subdirectory("Persistence_Level_Pool_Hybrid") +add_subdirectory("RFC_Forecasts") + +add_dependencies(hydro_routing_reservoirs hydro_utils) diff --git a/hydro/Routing/Reservoirs/Level_Pool/CMakeLists.txt b/hydro/Routing/Reservoirs/Level_Pool/CMakeLists.txt new file mode 100644 index 0000000000..b197da733f --- /dev/null +++ b/hydro/Routing/Reservoirs/Level_Pool/CMakeLists.txt @@ -0,0 +1,7 @@ +add_library(hydro_routing_reservoirs_levelpool STATIC + module_levelpool.F90 + module_levelpool_state.F90 + module_levelpool_properties.F90 +) + +add_dependencies(hydro_routing_reservoirs_levelpool hydro_routing_reservoirs) diff --git a/hydro/Routing/Reservoirs/Level_Pool/Makefile b/hydro/Routing/Reservoirs/Level_Pool/Makefile index 3497598e79..807db31c4f 100644 --- a/hydro/Routing/Reservoirs/Level_Pool/Makefile +++ b/hydro/Routing/Reservoirs/Level_Pool/Makefile @@ -3,7 +3,7 @@ include ../../../macros MODFLAG := -I ../../../MPP -I ../../../mod -%.o : %.F +%.o : %.F90 $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $< .PHONY: all mod test @@ -12,10 +12,10 @@ all: mod mod: #Build each sub module then build the module that depends on all sub modules - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool_properties.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool_state.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool_tests.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool_properties.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool_state.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_levelpool_tests.F90 ar -r ../../../lib/libHYDRO.a module_levelpool_properties.o ar -r ../../../lib/libHYDRO.a module_levelpool_state.o ar -r ../../../lib/libHYDRO.a module_levelpool.o diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F rename to hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F rename to hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_state.F b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_state.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Level_Pool/module_levelpool_state.F rename to hydro/Routing/Reservoirs/Level_Pool/module_levelpool_state.F90 diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_tests.F b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_tests.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Level_Pool/module_levelpool_tests.F rename to hydro/Routing/Reservoirs/Level_Pool/module_levelpool_tests.F90 diff --git a/hydro/Routing/Reservoirs/Makefile b/hydro/Routing/Reservoirs/Makefile index b3df13694d..21c10096a0 100644 --- a/hydro/Routing/Reservoirs/Makefile +++ b/hydro/Routing/Reservoirs/Makefile @@ -3,7 +3,7 @@ include ../../macros MODFLAG := $(MODFLAG) -I ../../mod -%.o : %.F +%.o : %.F90 $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $< .PHONY: all mod test @@ -18,10 +18,10 @@ all: mod mod: ../../MPP/module_mpp_land.mod ../../utils/module_hydro_stop.mod #Build each sub module then build the module that depends on all sub modules - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_utilities.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_timeslice_data.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_rfc_time_series_data.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_utilities.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_timeslice_data.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_rfc_time_series_data.F90 ar -r ../../lib/libHYDRO.a module_reservoir_utilities.o ar -r ../../lib/libHYDRO.a module_reservoir.o @@ -37,17 +37,17 @@ mod: ../../MPP/module_mpp_land.mod ../../utils/module_hydro_stop.mod test: ../../MPP/module_mpp_land.mod ../../utils/module_hydro_stop.mod - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_utilities.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_timeslice_data.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_rfc_time_series_data.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_utilities.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_timeslice_data.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_reservoir_read_rfc_time_series_data.F90 make -C Level_Pool make -C Persistence_Level_Pool_Hybrid make -C RFC_Forecasts - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) reservoir_tests.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) reservoir_tests.F90 $(COMPILER90) $(NETCDFLIB) -o reservoir_tests \ diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/CMakeLists.txt b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/CMakeLists.txt new file mode 100644 index 0000000000..a6d6b09760 --- /dev/null +++ b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/CMakeLists.txt @@ -0,0 +1,13 @@ +add_library(hydro_routing_reservoirs_hybrid STATIC + module_persistence_levelpool_hybrid.F90 + module_persistence_levelpool_hybrid_state.F90 + module_persistence_levelpool_hybrid_properties.F90 +) + +add_dependencies(hydro_routing_reservoirs_hybrid hydro_routing_reservoirs) + +target_include_directories(hydro_routing_reservoirs_hybrid + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/Makefile b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/Makefile index 666d262893..66bed3af56 100644 --- a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/Makefile +++ b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/Makefile @@ -3,7 +3,7 @@ include ../../../macros MODFLAG := -I ../../../MPP -I ../../../mod -%.o : %.F +%.o : %.F90 $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $< .PHONY: all mod test @@ -12,10 +12,10 @@ all: mod mod: #Build each sub module then build the module that depends on all sub modules - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid_properties.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid_state.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid_tests.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid_properties.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid_state.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_persistence_levelpool_hybrid_tests.F90 ar -r ../../../lib/libHYDRO.a module_persistence_levelpool_hybrid_properties.o ar -r ../../../lib/libHYDRO.a module_persistence_levelpool_hybrid_state.o ar -r ../../../lib/libHYDRO.a module_persistence_levelpool_hybrid.o diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F rename to hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F rename to hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F90 diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_state.F b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_state.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_state.F rename to hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_state.F90 diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_tests.F b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_tests.F90 similarity index 100% rename from hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_tests.F rename to hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_tests.F90 diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/CMakeLists.txt b/hydro/Routing/Reservoirs/RFC_Forecasts/CMakeLists.txt new file mode 100644 index 0000000000..1a1ac2bcf1 --- /dev/null +++ b/hydro/Routing/Reservoirs/RFC_Forecasts/CMakeLists.txt @@ -0,0 +1,16 @@ +add_library(hydro_routing_reservoirs_rfc STATIC + module_rfc_forecasts.F90 + module_rfc_forecasts_state.F90 + module_rfc_forecasts_properties.F90 +) + +add_dependencies(hydro_routing_reservoirs_rfc + hydro_routing_reservoirs + hydro_routing_reservoirs_levelpool +) + +target_include_directories(hydro_routing_reservoirs_rfc + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/Makefile b/hydro/Routing/Reservoirs/RFC_Forecasts/Makefile index 82b95fc672..549b51e6d4 100644 --- a/hydro/Routing/Reservoirs/RFC_Forecasts/Makefile +++ b/hydro/Routing/Reservoirs/RFC_Forecasts/Makefile @@ -3,7 +3,7 @@ include ../../../macros MODFLAG := -I ../../../MPP -I ../../../mod -%.o : %.F +%.o : %.F90 $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $< .PHONY: all mod test @@ -12,10 +12,10 @@ all: mod mod: #Build each sub module then build the module that depends on all sub modules - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts_properties.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts_state.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts_tests.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts_properties.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts_state.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_rfc_forecasts_tests.F90 ar -r ../../../lib/libHYDRO.a module_rfc_forecasts_properties.o ar -r ../../../lib/libHYDRO.a module_rfc_forecasts_state.o ar -r ../../../lib/libHYDRO.a module_rfc_forecasts.o diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 similarity index 100% rename from hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F rename to hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F90 similarity index 100% rename from hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F rename to hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F90 diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F90 similarity index 100% rename from hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F rename to hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F90 diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_tests.F b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_tests.F90 similarity index 100% rename from hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_tests.F rename to hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_tests.F90 diff --git a/hydro/Routing/Reservoirs/module_reservoir.F b/hydro/Routing/Reservoirs/module_reservoir.F90 similarity index 100% rename from hydro/Routing/Reservoirs/module_reservoir.F rename to hydro/Routing/Reservoirs/module_reservoir.F90 diff --git a/hydro/Routing/Reservoirs/module_reservoir_read_rfc_time_series_data.F b/hydro/Routing/Reservoirs/module_reservoir_read_rfc_time_series_data.F90 similarity index 100% rename from hydro/Routing/Reservoirs/module_reservoir_read_rfc_time_series_data.F rename to hydro/Routing/Reservoirs/module_reservoir_read_rfc_time_series_data.F90 diff --git a/hydro/Routing/Reservoirs/module_reservoir_read_timeslice_data.F b/hydro/Routing/Reservoirs/module_reservoir_read_timeslice_data.F90 similarity index 100% rename from hydro/Routing/Reservoirs/module_reservoir_read_timeslice_data.F rename to hydro/Routing/Reservoirs/module_reservoir_read_timeslice_data.F90 diff --git a/hydro/Routing/Reservoirs/module_reservoir_utilities.F b/hydro/Routing/Reservoirs/module_reservoir_utilities.F90 similarity index 100% rename from hydro/Routing/Reservoirs/module_reservoir_utilities.F rename to hydro/Routing/Reservoirs/module_reservoir_utilities.F90 diff --git a/hydro/Routing/Reservoirs/reservoir_tests.F b/hydro/Routing/Reservoirs/reservoir_tests.F90 similarity index 100% rename from hydro/Routing/Reservoirs/reservoir_tests.F rename to hydro/Routing/Reservoirs/reservoir_tests.F90 diff --git a/hydro/Routing/Subsurface/CMakeLists.txt b/hydro/Routing/Subsurface/CMakeLists.txt new file mode 100644 index 0000000000..be0f9eb457 --- /dev/null +++ b/hydro/Routing/Subsurface/CMakeLists.txt @@ -0,0 +1,11 @@ +add_library(hydro_routing_subsurface STATIC + module_subsurface_input.F90 + module_subsurface_output.F90 + module_subsurface_static_data.F90 + module_subsurface_grid_transform.F90 + module_subsurface_properties.F90 + module_subsurface_state.F90 + module_subsurface.F90 +) + +target_link_libraries(hydro_routing_subsurface PRIVATE hydro_routing_overland) diff --git a/hydro/Routing/Subsurface/Makefile b/hydro/Routing/Subsurface/Makefile index 8cc63623dd..4b9e1ea473 100644 --- a/hydro/Routing/Subsurface/Makefile +++ b/hydro/Routing/Subsurface/Makefile @@ -20,13 +20,13 @@ all: mod mod: #Build each sub module then build the module that depends on all sub modules - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_grid_transform.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_properties.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_state.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_static_data.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_output.F - $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_input.F + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_grid_transform.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_properties.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_state.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_static_data.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_output.F90 + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) module_subsurface_input.F90 ar -r ../../lib/libHYDRO.a module_subsurface_grid_transform.o ar -r ../../lib/libHYDRO.a module_subsurface_properties.o ar -r ../../lib/libHYDRO.a module_subsurface_state.o @@ -37,7 +37,7 @@ mod: cp *.mod ../../mod test: - $(COMPILER90) $(F90FLAGS) $(MODFLAG) subsurface_tests.F + $(COMPILER90) $(F90FLAGS) $(MODFLAG) subsurface_tests.F90 $(COMPILER90) -o subsurface_tests \ module_subsurface_grid_transform.o \ module_subsurface_properties.o \ diff --git a/hydro/Routing/Subsurface/module_subsurface.F b/hydro/Routing/Subsurface/module_subsurface.F90 similarity index 100% rename from hydro/Routing/Subsurface/module_subsurface.F rename to hydro/Routing/Subsurface/module_subsurface.F90 diff --git a/hydro/Routing/Subsurface/module_subsurface_grid_transform.F b/hydro/Routing/Subsurface/module_subsurface_grid_transform.F90 similarity index 100% rename from hydro/Routing/Subsurface/module_subsurface_grid_transform.F rename to hydro/Routing/Subsurface/module_subsurface_grid_transform.F90 diff --git a/hydro/Routing/Subsurface/module_subsurface_input.F b/hydro/Routing/Subsurface/module_subsurface_input.F90 similarity index 100% rename from hydro/Routing/Subsurface/module_subsurface_input.F rename to hydro/Routing/Subsurface/module_subsurface_input.F90 diff --git a/hydro/Routing/Subsurface/module_subsurface_output.F b/hydro/Routing/Subsurface/module_subsurface_output.F90 similarity index 100% rename from hydro/Routing/Subsurface/module_subsurface_output.F rename to hydro/Routing/Subsurface/module_subsurface_output.F90 diff --git a/hydro/Routing/Subsurface/module_subsurface_properties.F b/hydro/Routing/Subsurface/module_subsurface_properties.F90 similarity index 100% rename from hydro/Routing/Subsurface/module_subsurface_properties.F rename to hydro/Routing/Subsurface/module_subsurface_properties.F90 diff --git a/hydro/Routing/Subsurface/module_subsurface_state.F b/hydro/Routing/Subsurface/module_subsurface_state.F90 similarity index 100% rename from hydro/Routing/Subsurface/module_subsurface_state.F rename to hydro/Routing/Subsurface/module_subsurface_state.F90 diff --git a/hydro/Routing/Subsurface/module_subsurface_static_data.F b/hydro/Routing/Subsurface/module_subsurface_static_data.F90 similarity index 98% rename from hydro/Routing/Subsurface/module_subsurface_static_data.F rename to hydro/Routing/Subsurface/module_subsurface_static_data.F90 index cf31cf4de7..0ba4de5abd 100644 --- a/hydro/Routing/Subsurface/module_subsurface_static_data.F +++ b/hydro/Routing/Subsurface/module_subsurface_static_data.F90 @@ -2,13 +2,13 @@ module module_subsurface_static_data implicit none type subsurface_static_interface - + integer :: ixrt integer :: jxrt integer :: nsoil real :: dt - integer :: rt_option - + integer :: rt_option + contains procedure :: init => subsurface_static_data_init procedure :: destroy => subsurface_static_data_destroy diff --git a/hydro/Routing/Subsurface/subsurface_tests.F b/hydro/Routing/Subsurface/subsurface_tests.F90 similarity index 100% rename from hydro/Routing/Subsurface/subsurface_tests.F rename to hydro/Routing/Subsurface/subsurface_tests.F90 diff --git a/hydro/Routing/module_GW_baseflow.F b/hydro/Routing/module_GW_baseflow.F90 similarity index 97% rename from hydro/Routing/module_GW_baseflow.F rename to hydro/Routing/module_GW_baseflow.F90 index fbbf534adb..0ad973bb60 100644 --- a/hydro/Routing/module_GW_baseflow.F +++ b/hydro/Routing/module_GW_baseflow.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: module module_GW_baseflow @@ -34,7 +34,7 @@ module module_GW_baseflow contains !------------------------------------------------------------------------------ -!DJG Simple GW Bucket Model +!DJG Simple GW Bucket Model ! for NHDPLUS mapping !------------------------------------------------------------------------------ @@ -51,19 +51,19 @@ subroutine simp_gw_buck_nhd( & qout_gwsubbas, qin_gwsubbas, & qloss_gwsubbas, & GWBASESWCRT, OVRTSWCRT, & - LNLINKSL, & + LNLINKSL, & basns_area, & nhdBuckMask, bucket_loss, & - channelBucket_only ) + channelBucket_only ) use module_UDMAP, only: LNUMRSL, LUDRSL implicit none - + !!!Declarations... integer, intent(in) :: ix,jx,ixrt,jxrt integer, intent(in) :: numbasns, lnlinksl - real, intent(in), dimension(ix,jx) :: runoff2x_in + real, intent(in), dimension(ix,jx) :: runoff2x_in real, dimension(ixrt,jxrt) :: runoff2x , runoff1x real, intent(in), dimension(ix,jx) :: runoff1x_in, area_lsm real, intent(in) :: cellArea(ixrt,jxrt),DT @@ -81,7 +81,7 @@ subroutine simp_gw_buck_nhd( & integer, intent(in) :: OVRTSWCRT real, intent(in), dimension(numbasns) :: basns_area integer, intent(in) :: channelBucket_only - integer, intent(in) :: bucket_loss + integer, intent(in) :: bucket_loss real, dimension(numbasns) :: net_perc integer, dimension(numbasns) :: nhdBuckMask @@ -118,7 +118,7 @@ subroutine simp_gw_buck_nhd( & do AGGFACXRT=AGGFACTRT-1,0,-1 IXXRT=I*AGGFACTRT-AGGFACXRT JYYRT=J*AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND +#ifdef MPP_LAND if(left_id.ge.0) IXXRT=IXXRT+1 if(down_id.ge.0) JYYRT=JYYRT+1 ! if(AGGFACTRT .eq. 1) then @@ -149,7 +149,7 @@ subroutine simp_gw_buck_nhd( & LQLateral = 0 do k = 1, LNUMRSL ! get from land grid runoff - do m = 1, LUDRSL(k)%ncell + do m = 1, LUDRSL(k)%ncell ii = LUDRSL(k)%cell_i(m) jj = LUDRSL(k)%cell_j(m) if(ii .gt. 0 .and. jj .gt. 0) then @@ -181,7 +181,7 @@ subroutine simp_gw_buck_nhd( & if(channelBucket_only .eq. 0) then !! If not using channelBucket_only, save qin_gwsubbas qin_gwsubbas(bas) = net_perc(bas) !units (m^3) - else + else !! If using channelBucket_only, get net_perc from the passed qin_gwsubbas net_perc(bas) = qin_gwsubbas(bas) !units (m^3) end if @@ -203,12 +203,12 @@ subroutine simp_gw_buck_nhd( & ! if(z_mx(bas) .gt. 5) then ! z_mx(bas) = z_mx(bas) * mm_to_m ! change from mm to meters ! endif - + if (z_gwsubbas(bas).gt.z_mx(bas) * mm_to_m) then !If/then for bucket overflow case... z_gw_spill = z_gwsubbas(bas) - z_mx(bas) * mm_to_m ! meters z_gwsubbas(bas) = z_mx(bas) * mm_to_m ! meters - + else z_gw_spill = 0. end if ! End if for bucket overflow case... @@ -220,18 +220,18 @@ subroutine simp_gw_buck_nhd( & ! Assume exponential relation between z/zmax and Q... -!DJG force asymptote to zero to prevent 'overdraft'... +!DJG force asymptote to zero to prevent 'overdraft'... if(GWBASESWCRT.eq.1) then ! Exponential model qout_gwsubbas(bas) = C(bas)*(exp(ex(bas)*z_gwsubbas(bas)/(z_mx(bas) * mm_to_m))-1) ! q_out (m^3/s) elseif(GWBASESWCRT.eq.4) then ! Updated exponential model normalized by area qout_gwsubbas(bas) = C(bas)*(basns_area(bas)*sqm_to_sqkm)*(exp(ex(bas)*z_gwsubbas(bas)/(z_mx(bas)*mm_to_m))-1) ! q_out (m^3/s) - + end if !DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit (m^3/s) - + if (bucket_loss .eq. 1) then qloss_gwsubbas(bas) = qout_gwsubbas(bas)*loss_fraction(bas) qout_gwsubbas(bas) = qout_gwsubbas(bas)-qloss_gwsubbas(bas) @@ -284,13 +284,13 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,& C,ex,z_mx,GWBASESWCRT,OVRTSWCRT) implicit none - + !!!Declarations... integer, intent(in) :: ix,jx,ixrt,jxrt integer, intent(in) :: numbasns, gnumbasns integer, intent(in), dimension(ix,jx) :: gwsubbasmsk - real, intent(in), dimension(ix,jx) :: runoff2x_in - real, dimension(ix,jx) :: runoff2x + real, intent(in), dimension(ix,jx) :: runoff2x_in + real, dimension(ix,jx) :: runoff2x real, intent(in), dimension(ix,jx) :: runoff1x_in real, dimension(ix,jx) :: runoff1x real, intent(in) :: basns_area(numbasns),dist(ixrt,jxrt,9),DT @@ -306,7 +306,7 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g integer, intent(in),dimension(ixrt,jxrt) :: gw_strm_msk, gw_strm_msk_lind integer, intent(in) :: GWBASESWCRT integer, intent(in) :: OVRTSWCRT - + real*8, dimension(numbasns) :: sum_perc8, ct_bas8, sum_perc8_surf real, dimension(numbasns) :: sum_perc, sum_perc_surf @@ -371,7 +371,7 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g sum_perc = sum_perc8 sum_perc_surf = sum_perc8_surf ct_bas = ct_bas8 - + @@ -430,10 +430,10 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g ! Assume exponential relation between z/zmax and Q... !DJG...old...creates non-asymptotic flow... qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) -!DJG force asymptote to zero to prevent 'overdraft'... +!DJG force asymptote to zero to prevent 'overdraft'... !DJG debug hardwire test... qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s) qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s) - + !DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit @@ -524,20 +524,20 @@ subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns,gnumbasns,bas integer :: i,j,ixrt,jxrt,numbasns, bas, gnumbasns, k integer,dimension(ixrt,jxrt) :: in_gw_strm_msk integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk - real,dimension(numbasns) :: gwbas_pix_ct - real,dimension(gnumbasns) :: tmp_gwbas_pix_ct + real,dimension(numbasns) :: gwbas_pix_ct + real,dimension(gnumbasns) :: tmp_gwbas_pix_ct integer(kind=int64), intent(in), dimension(:) :: basnsInd gw_strm_msk = 0 - call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk) - - call mpp_land_sync() + call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk) + + call mpp_land_sync() if(my_id .eq. IO_id) then ! tmp_gwbas_pix_ct = 0.0 -! do bas = 1,gnumbasns +! do bas = 1,gnumbasns ! do i=1,global_rt_nx ! do j=1,global_rt_ny ! if(gw_strm_msk(i,j) .eq. bas) then @@ -558,7 +558,7 @@ subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns,gnumbasns,bas end do end if - call mpp_land_sync() + call mpp_land_sync() if(gnumbasns .gt. 0) then call mpp_land_bcast_real(gnumbasns,tmp_gwbas_pix_ct) @@ -577,4 +577,4 @@ end subroutine pix_ct_1 -end module module_GW_baseflow +end module module_GW_baseflow diff --git a/hydro/Routing/module_HYDRO_io.F b/hydro/Routing/module_HYDRO_io.F90 similarity index 99% rename from hydro/Routing/module_HYDRO_io.F rename to hydro/Routing/module_HYDRO_io.F90 index b4312a88eb..c8dfc4388c 100644 --- a/hydro/Routing/module_HYDRO_io.F +++ b/hydro/Routing/module_HYDRO_io.F90 @@ -35,7 +35,7 @@ module module_HYDRO_io use netcdf use module_hydro_stop, only:HYDRO_stop use hashtable - use iso_fortran_env, only: int64 + use iso_fortran_env, only: int64, compiler_version implicit none @@ -1518,7 +1518,8 @@ subroutine read_GWBUCKPARM (inFile, numbasns, gnumbasns, basnsInd, & implicit none integer, intent(in) :: gnumbasns, numbasns integer(kind=int64), intent(in), dimension(numbasns) :: basnsInd - real, intent(out), dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, gw_buck_loss + real, intent(out), dimension(numbasns) :: gw_buck_coeff, gw_buck_exp + real, intent(out), dimension(:), allocatable :: gw_buck_loss real, intent(out), dimension(numbasns) :: z_max, z_gwsubbas, basns_area integer, intent(out), dimension(numbasns) :: bas_id real, dimension(gnumbasns) :: tmp_buck_coeff, tmp_buck_exp, tmp_buck_loss @@ -2451,10 +2452,10 @@ subroutine output_gw_spinup(igrid, split_output_count, ixrt, jxrt, & #endif - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_gw_spinup() - Problem nf90_create") - endif + endif iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times) iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid @@ -2789,7 +2790,7 @@ subroutine sub_output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & #endif - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_gw_spinup() - Problem nf90_create") endif @@ -3213,15 +3214,15 @@ subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create points") - endif + endif - iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2) + iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create observation") - endif + endif do i=1,nlk if(ORDER(i) .ge. order_to_write) then @@ -3968,12 +3969,12 @@ subroutine output_chrt_bak(igrid, split_output_count, NLINKS, ORDER, print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create points") endif - iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2) + iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create observation") endif @@ -4880,10 +4881,10 @@ subroutine output_lakes(igrid, split_output_count, NLAKES, & print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_lakes() - Problem nf90_create") - endif + endif do i=1,NLAKES station_id(i) = i @@ -5114,10 +5115,10 @@ subroutine output_lakes2(igrid, split_output_count, NLAKES, & print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_lakes() - Problem nf90_create") - endif + endif iret = nf90_def_dim(ncid, "station", nlakes, stationdim) @@ -5329,10 +5330,10 @@ subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & !--- define dimension - iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_chrtgrd() - Problem nf90_create") - endif + endif iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, timedim) iret = nf90_def_dim(ncid, "x", ixrt, ixlondim) @@ -5755,7 +5756,7 @@ subroutine output_lsm(outFile,did) if(IO_id.eq.my_id) & #endif - iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) @@ -6006,6 +6007,7 @@ subroutine RESTART_OUT_nc(outFile,did) ! nlst(did)%GWBASESWCRT .ne. 0 ) ! put global attribute + iret = nf90_put_att(ncid, NF90_GLOBAL, "compiler_version", compiler_version()) iret = nf90_put_att(ncid, NF90_GLOBAL, "his_out_counts", rt_domain(did)%his_out_counts) iret = nf90_put_att(ncid, NF90_GLOBAL, "Restart_Time", nlst(did)%olddate(1:19)) iret = nf90_put_att(ncid, NF90_GLOBAL, "Since_Date", nlst(did)%sincedate(1:19)) @@ -8927,9 +8929,9 @@ subroutine outPutChanInfo(fromNode,toNode,chlon,chlat) real, dimension(:) :: chlat,chlon integer :: iret, nodes, i, ncid, dimid_n, varid - nodes = size(chlon,1) + nodes = size(chlon,1) - iret = nf90_create("nodeInfor.nc", OR(NF90_CLOBBER, NF90_NETCDF4), ncid) + iret = nf90_create("nodeInfor.nc", OR(NF90_CLOBBER, NF90_NETCDF4), ncid) iret = nf90_def_dim(ncid, "node", nodes, dimid_n) !-- make a decimated grid ! define the varialbes iret = nf90_def_var(ncid, "fromNode", NF90_INT, (/dimid_n/), varid) @@ -9019,7 +9021,7 @@ subroutine read_route_link_netcdf( route_link_file, & call get_1d_netcdf_real(ncid, 'Length', CHANLEN, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'n', MannN, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'So', So, 'read_route_link_netcdf', .TRUE.) -!! impose a minimum as this sometimes fails in the file. +!! impose a minimum as this sometimes fails in the file. where(So .lt. 0.00001) So=0.00001 call get_1d_netcdf_real(ncid, 'ChSlp', ChSSlp, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'BtmWdth', Bw, 'read_route_link_netcdf', .TRUE.) @@ -10245,9 +10247,9 @@ subroutine output_gw_netcdf(igrid, split_output_count, nbasns, & iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then - print*, "Problem nf90_create" - call hydro_stop("output_gw_netcdf") - endif + print*, "Problem nf90_create" + call hydro_stop("output_gw_netcdf") + endif !!! Define dimensions @@ -11219,7 +11221,7 @@ subroutine read2dlsm(did,file,varName,varOut,ierr,rt) if (present(rt)) then regrid = rt - else + else regrid = .false. endif diff --git a/hydro/Routing/module_HYDRO_utils.F b/hydro/Routing/module_HYDRO_utils.F90 similarity index 88% rename from hydro/Routing/module_HYDRO_utils.F rename to hydro/Routing/module_HYDRO_utils.F90 index 37155c66a2..2ff1748952 100644 --- a/hydro/Routing/module_HYDRO_utils.F +++ b/hydro/Routing/module_HYDRO_utils.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: module module_HYDRO_utils @@ -32,8 +32,8 @@ module module_HYDRO_utils implicit none - logical lr_dist_flag !land routing distance calculated or not. - + logical lr_dist_flag !land routing distance calculated or not. + contains integer function get2d_real(var_name,out_buff,ix,jx,fileName) @@ -44,7 +44,7 @@ integer function get2d_real(var_name,out_buff,ix,jx,fileName) character(len=*), intent(in) :: var_name character(len=*), intent(in) :: fileName get2d_real = -1 - + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) if (iret .ne. 0) then #ifdef HYDRO_D @@ -68,10 +68,10 @@ integer function get2d_real(var_name,out_buff,ix,jx,fileName) get2d_real = ivar end function get2d_real - + ! this module create the distance dx, dy and diagnoal for routing ! 8 direction as the slop: -! 1: i,j+1 +! 1: i,j+1 ! 2: i+1, j+1 ! 3: i+1, j ! 4: i+1, j-1 @@ -79,10 +79,10 @@ end function get2d_real ! 6: i-1, j-1 ! 7: i-1, j ! 8: i-1, j+1 - real function get_dy(i,j,v,ix,jx) + real function get_dy(i,j,v,ix,jx) ! south north integer :: i,j,ix,jx - real,dimension(ix,jx,9) :: v + real,dimension(ix,jx,9) :: v if( v(i,j,1) .le. 0) then get_dy = v(i,j,5) else if( v(i,j,5) .le. 0) then @@ -93,10 +93,10 @@ real function get_dy(i,j,v,ix,jx) return end function get_dy - real function get_dx(i,j,v,ix,jx) + real function get_dx(i,j,v,ix,jx) ! east-west integer :: i,j, ix,jx - real,dimension(ix,jx,9) :: v + real,dimension(ix,jx,9) :: v if( v(i,j,3) .le. 0) then get_dx = v(i,j,7) else if( v(i,j,7) .le. 0) then @@ -121,11 +121,11 @@ real function get_ll_d(lat1_in, lat2_in, lon1_in, lon2_in) dlat = lat2 -lat1 dlon = lon2 -lon1 a = sin(dlat/2)*sin(dlat/2) + cos(lat1)*cos(lat2)*sin(dlon/2)*sin(dlon/2) - b1 = sqrt(a) - b2 = sqrt(1-a) + b1 = sqrt(a) + b2 = sqrt(1-a) c = 2.0*atan2(b1,b2) get_ll_d = R*c - return + return end function get_ll_d @@ -141,7 +141,7 @@ real function get_ll_d_tmp(lat1_in, lat2_in, lon1_in, lon2_in) lon2 = lon2_in * pai/180 r = 6371*1000 get_ll_d_tmp = acos(sin(lat1)*sin(lat2)+cos(lat1)*cos(lat2)*cos(lon2-lon1))*r - return + return end function get_ll_d_tmp @@ -156,7 +156,7 @@ subroutine get_rt_dxdy_ll(did) real, dimension(global_rt_nx,global_rt_ny):: latrt, lonrt real, dimension(global_rt_nx,global_rt_ny,9):: dist if(my_id .eq. IO_id) then - ! read the lat and lon. + ! read the lat and lon. iret = get2d_real("LONGITUDE",lonrt,global_rt_nx,global_rt_ny,& trim(nlst(did)%GEO_FINEGRID_FLNM )) iret = get2d_real("LATITUDE",latrt,global_rt_nx,global_rt_ny,& @@ -169,7 +169,7 @@ subroutine get_rt_dxdy_ll(did) end do #else real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt):: latrt, lonrt - ! read the lat and lon. + ! read the lat and lon. iret = get2d_real("LONGITUDE",lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,& trim(nlst(did)%GEO_FINEGRID_FLNM )) iret = get2d_real("LATITUDE",latrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,& @@ -179,14 +179,14 @@ subroutine get_rt_dxdy_ll(did) end subroutine get_rt_dxdy_ll -! get dx and dy of lat and lon +! get dx and dy of lat and lon subroutine get_dist_ll(dist,lat,lon,ix,jx) implicit none - integer:: ix,jx + integer:: ix,jx real, dimension(ix,jx,9):: dist real, dimension(ix,jx):: lat, lon - integer:: i,j - real x,y + integer:: i,j + real x,y dist = -1 do j = 1, jx do i = 1, ix @@ -194,25 +194,25 @@ subroutine get_dist_ll(dist,lat,lon,ix,jx) get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1)) if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = & get_ll_d(lat(i,j), lat(i+1,j+1), lon(i,j), lon(i+1,j+1)) - if(i .lt. ix) dist(i,j,3) = & + if(i .lt. ix) dist(i,j,3) = & get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j)) - if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = & + if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = & get_ll_d(lat(i,j), lat(i+1,j-1), lon(i,j), lon(i+1,j-1)) - if(j .gt. 1 ) dist(i,j,5) = & + if(j .gt. 1 ) dist(i,j,5) = & get_ll_d(lat(i,j), lat(i,j-1), lon(i,j), lon(i,j-1)) - if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = & + if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = & get_ll_d(lat(i,j), lat(i-1,j-1), lon(i,j), lon(i-1,j-1)) - if(i .gt. 1) dist(i,j,7) = & + if(i .gt. 1) dist(i,j,7) = & get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j)) - if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = & + if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = & get_ll_d(lat(i,j), lat(i-1,j+1), lon(i,j), lon(i-1,j+1)) end do end do - do j = 1, jx + do j = 1, jx do i = 1, ix if(j.eq.1) then y = get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1)) - else if(j.eq.jx) then + else if(j.eq.jx) then y = get_ll_d(lat(i,j-1), lat(i,j), lon(i,j-1), lon(i,j)) else y = get_ll_d(lat(i,j-1), lat(i,j+1), lon(i,j-1), lon(i,j+1))/2.0 @@ -225,7 +225,7 @@ subroutine get_dist_ll(dist,lat,lon,ix,jx) else x = get_ll_d(lat(i-1,j), lat(i+1,j), lon(i-1,j), lon(i+1,j))/2.0 endif - dist(i,j,9) = x * y + dist(i,j,9) = x * y end do end do #ifdef HYDRO_D @@ -236,9 +236,9 @@ end subroutine get_dist_ll ! get dx and dy of map projected subroutine get_dxdy_mp(dist,ix,jx,dx,dy) implicit none - integer:: ix,jx + integer:: ix,jx real :: dx,dy - integer:: i,j + integer:: i,j real :: v1 ! out variable real, dimension(ix,jx,9)::dist @@ -246,14 +246,14 @@ subroutine get_dxdy_mp(dist,ix,jx,dx,dy) v1 = sqrt(dx*dx + dy*dy) do j = 1, jx do i = 1, ix - if(j .lt. jx) dist(i,j,1) = dy - if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = v1 - if(i .lt. ix) dist(i,j,3) = dx - if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = v1 - if(j .gt. 1 ) dist(i,j,5) = dy - if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = v1 - if(i .gt. 1) dist(i,j,7) = dx - if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = v1 + if(j .lt. jx) dist(i,j,1) = dy + if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = v1 + if(i .lt. ix) dist(i,j,3) = dx + if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = v1 + if(j .gt. 1 ) dist(i,j,5) = dy + if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = v1 + if(i .gt. 1) dist(i,j,7) = dx + if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = v1 dist(i,j,9) = dx * dy end do end do @@ -267,16 +267,16 @@ subroutine get_dist_lsm(did) #ifdef MPP_LAND integer ix,jx,ixrt,jxrt, k real , dimension(global_nx,global_ny):: latitude,longitude - real, dimension(global_nx,global_ny,9):: dist + real, dimension(global_nx,global_ny,9):: dist if(nlst(did)%dxrt0 .lt. 0) then ! lat and lon grid - call write_io_real(rt_domain(did)%lat_lsm,latitude) - call write_io_real(rt_domain(did)%lon_lsm,longitude) + call write_io_real(rt_domain(did)%lat_lsm,latitude) + call write_io_real(rt_domain(did)%lon_lsm,longitude) if(my_id.eq.IO_id) then call get_dist_ll(dist,latitude,longitude, & global_nx,global_ny) endif - + else ! mapp projected grid. if(my_id.eq.IO_id) then @@ -345,22 +345,22 @@ end subroutine get_dist_lrt ! end do !#endif ! end subroutine get_dist_crt - + subroutine get_basn_area(did) implicit none integer :: did, ix,jx, k real :: basns_area(rt_domain(did)%gnumbasns) #ifdef MPP_LAND - integer :: mask(global_nx, global_ny) - real :: dist_lsm(global_nx, global_ny,9) + integer :: mask(global_nx, global_ny) + real :: dist_lsm(global_nx, global_ny,9) #else integer :: mask(rt_domain(did)%ix, rt_domain(did)%jx) - real :: dist_lsm(rt_domain(did)%ix, rt_domain(did)%jx,9) + real :: dist_lsm(rt_domain(did)%ix, rt_domain(did)%jx,9) #endif #ifdef MPP_LAND ix = global_nx jx = global_ny - call write_IO_int(rt_domain(did)%GWSUBBASMSK,mask) + call write_IO_int(rt_domain(did)%GWSUBBASMSK,mask) do k = 1, 9 call write_IO_real(rt_domain(did)%dist_lsm(:,:,k),dist_lsm(:,:,k)) end do @@ -402,7 +402,7 @@ subroutine get_area_g(basns_area,GWSUBBASMSK, numbasns,ix,jx,dist) end do do i = 1, numbasns if(count(i) .gt. 0) then - basns_area(i) = basns_area(i) / count(i) + basns_area(i) = basns_area(i) / count(i) end if end do end subroutine get_area_g @@ -436,6 +436,6 @@ subroutine get_node_area(did) call get_area_g8(rt_domain(did)%node_area, rt_domain(did)%CH_NETLNK, & rt_domain(did)%NLINKS,rt_domain(did)%ixrt, rt_domain(did)%jxrt, rt_domain(did)%overland%properties%distance_to_neighbor) end subroutine get_node_area - + end module module_HYDRO_utils diff --git a/hydro/Routing/module_NWM_io.F b/hydro/Routing/module_NWM_io.F90 similarity index 98% rename from hydro/Routing/module_NWM_io.F rename to hydro/Routing/module_NWM_io.F90 index 676482a8af..efaa6c74a4 100644 --- a/hydro/Routing/module_NWM_io.F +++ b/hydro/Routing/module_NWM_io.F90 @@ -8,8 +8,7 @@ module module_NWM_io use module_version, only: get_code_version, get_nwm_version use orchestrator_base use module_hydro_stop, only: HYDRO_stop - -use iso_fortran_env, only: int64 +use iso_fortran_env, only: int64, compiler_version implicit none @@ -233,13 +232,6 @@ subroutine output_chrt_NWM(domainId) gsize = rt_domain(domainId)%gnlinks endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(myId .eq. 0) then ! Allocate memory for output. allocate(g_chlon(gsize)) @@ -331,13 +323,6 @@ subroutine output_chrt_NWM(domainId) qlossLocal = RT_DOMAIN(domainId)%qloss !TML temp fix to test code endif - ! Sync everything up before the next step. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Loop through all the local links on this processor. For lake_type ! of 2, we need to manually set the streamflow and velocity values ! to the model NDV value. @@ -700,6 +685,8 @@ subroutine output_chrt_NWM(domainId) ! Write global attributes. iret = nf90_put_att(ftn,NF90_GLOBAL,"TITLE",trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create TITLE attribute') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"featureType",trim(fileMeta%fType)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create featureType attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"proj4",trim(fileMeta%proj4)) @@ -1014,13 +1001,6 @@ subroutine output_chrt_NWM(domainId) endif ! End if we are on master processor. - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Deallocate all memory. if(myId .eq. 0) then deallocate(varOutReal) @@ -1160,13 +1140,6 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i diagFlag = 0 #endif - ! Sync up processes. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! If we are running over MPI, determine which processor number we are on. ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then @@ -1340,7 +1313,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 0,0,0,0,0,0,0,0,0,0,& !31-40 0,0,0,0,1,0,0,0,0,0,& !41-50 0,0,0,0,0,0,0,0,0,0,& !51-60 - 1,0,1,1,1,1,0,1,0,1,& !61-70 + 1,0,1,1,1,1,0,1,1,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 0,0,0,0,0,1,1,1,& !91-98 @@ -1359,7 +1332,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 0,0,0,0,0,0,0,0,0,0,& !31-40 0,0,0,0,1,0,0,0,0,0,& !41-50 0,0,0,0,0,0,0,0,1,1,& !51-60 - 1,0,1,1,1,1,1,1,0,1,& !61-70 + 1,0,1,1,1,1,1,1,1,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 1,1,1,1,1,1,1,1,& !91-98 @@ -1391,13 +1364,6 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i ! call the GetModelConfigType function modelConfigType = GetModelConfigType(nlst(1)%io_config_outputs) - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(varInd .eq. 1) then ! We are on the first variable, we need to create the output file with ! attributes first. @@ -1421,6 +1387,8 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i ! Write global attributes iret = nf90_put_att(ftnNoahMP,NF90_GLOBAL,'TITLE',trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to place TITLE attribute into LDASOUT file.') + iret = nf90_put_att(ftnNoahMP,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftnNoahMP,NF90_GLOBAL,'model_initialization_time',trim(fileMeta%initTime)) call nwmCheck(diagFlag,iret,'ERROR: Unable to place model init time attribute into LDASOUT file.') iret = nf90_put_att(ftnNoahMP,NF90_GLOBAL,'model_output_valid_time',trim(fileMeta%validTime)) @@ -1685,13 +1653,6 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i end if ! End if we are on the I/O processor. endif ! End if we are on the first variable - ! Sync up all processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Place data into NetCDF file. This involves a few steps: ! 1.) Allocate an integer array of local grid size. ! 2.) Allocate an integer array of global grid size. @@ -1724,13 +1685,6 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i globalOutComp = fileMeta%fillComp(varInd) globalOutReal = fileMeta%fillReal(varInd) - ! Sync up processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - varRealTmp = varReal ! Reset any missing values that may exist. where ( varRealTmp .eq. fileMeta%modelNdv ) varRealTmp = fileMeta%fillReal(varInd) @@ -1752,12 +1706,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i else localCompTmp = NINT((varRealTmp(:,zTmp,:)-fileMeta%addOffset(varInd))/fileMeta%scaleFactor(varInd)) endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif + if(mppFlag .eq. 1) then #ifdef MPP_LAND call write_IO_int(localCompTmp,globalCompTmp) @@ -1767,12 +1716,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i globalCompTmp = localCompTmp globalRealTmp = varRealTmp(:,zTmp,:) endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif + ! Place output into global array to be written to NetCDF file. if(myId .eq. 0) then globalOutComp(:,zTmp,:) = globalCompTmp @@ -1780,13 +1724,6 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i endif end do - ! Sync up processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Write array out to NetCDF file. if(myId .eq. 0) then ! write(*,*) 'trude foo1' @@ -1824,13 +1761,6 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(myId .eq. 0) then ! Only close the file if we are finished with the very last variable. if(varInd .eq. fileMeta%numVars) then @@ -2032,6 +1962,8 @@ subroutine output_rt_NWM(domainId,iGrid) ! Write global attributes iret = nf90_put_att(ftn,NF90_GLOBAL,'TITLE',trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create TITLE attribute') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,'model_initialization_time',trim(fileMeta%initTime)) call nwmCheck(diagFlag,iret,'ERROR: Unable to place model init time attribute into RT_DOMAIN file.') iret = nf90_put_att(ftn,NF90_GLOBAL,'model_output_valid_time',trim(fileMeta%validTime)) @@ -2269,13 +2201,6 @@ subroutine output_rt_NWM(domainId,iGrid) endif ! End if statement if on I/O ID - ! Synce up processes. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Loop through each variable, collect local routing grid variables into a ! global routing grid and output through the master I/O process. do iTmp2=1,fileMeta%numVars @@ -2311,13 +2236,6 @@ subroutine output_rt_NWM(domainId,iGrid) localCompTmp = fileMeta%fillComp(iTmp2) localRealTmp = fileMeta%fillReal(iTmp2) - ! Sync up processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Loop through output array and convert floating point values to ! integers via scale_factor/add_offset. do iTmp = 1,RT_DOMAIN(domainId)%ixrt @@ -2372,13 +2290,6 @@ subroutine output_rt_NWM(domainId,iGrid) globalOutComp(:,zTmp,:) = localCompTmp globalOutReal(:,zTmp,:) = localRealTmp endif - - ! Sync up processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif end do ! End looping through levels ! Write output to NetCDF file. @@ -2573,13 +2484,6 @@ subroutine output_lakes_NWM(domainId,iGrid) if(mppFlag .eq. 1) then gSize = rt_domain(domainId)%NLAKES - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - allocate(g_lakeLon(gsize)) allocate(g_lakeLat(gsize)) allocate(g_lakeElev(gsize)) @@ -2613,13 +2517,6 @@ subroutine output_lakes_NWM(domainId,iGrid) g_lake_assimilated_value = RT_DOMAIN(domainID)%reservoir_assimilated_value g_lake_assimilated_source_file = RT_DOMAIN(domainID)%reservoir_assimilated_source_file - ! Sync everything up before the next step. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Collect arrays from various processors through MPI, and ! assemble into global arrays previously allocated. #ifdef MPP_LAND @@ -2663,13 +2560,6 @@ subroutine output_lakes_NWM(domainId,iGrid) g_lake_assimilated_source_file = RT_DOMAIN(domainID)%reservoir_assimilated_source_file endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Calculate datetime information. ! First compose strings of EPOCH and simulation start date. epochDate = trim("1970-01-01 00:00") @@ -2778,6 +2668,8 @@ subroutine output_lakes_NWM(domainId,iGrid) ! Write global attributes. iret = nf90_put_att(ftn,NF90_GLOBAL,"TITLE",trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create TITLE attribute') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"featureType",trim(fileMeta%fType)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create featureType attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"proj4",trim(fileMeta%proj4)) @@ -3102,13 +2994,6 @@ subroutine output_lakes_NWM(domainId,iGrid) endif ! End if we are on master processor. - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Deallocate all memory if(myId .eq. 0) then deallocate(varOutReal) @@ -3357,6 +3242,8 @@ subroutine output_chrtout_grd_NWM(domainId,iGrid) ! Write global attributes iret = nf90_put_att(ftn,NF90_GLOBAL,'TITLE',trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create TITLE attribute') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,'model_initialization_time',trim(fileMeta%initTime)) call nwmCheck(diagFlag,iret,'ERROR: Unable to place model init time attribute into RT_DOMAIN file.') iret = nf90_put_att(ftn,NF90_GLOBAL,'model_output_valid_time',trim(fileMeta%validTime)) @@ -3637,13 +3524,6 @@ subroutine output_chrtout_grd_NWM(domainId,iGrid) endif ! End if statement if on I/O ID -! Synce up processes. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(myId .eq. 0) then ! Close the output file iret = nf90_close(ftn) @@ -3729,13 +3609,6 @@ subroutine output_lsmOut_NWM(domainId) diagFlag = 0 #endif - ! Sync up processes. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! If we are running over MPI, determine which processor number we are on. ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then @@ -3808,13 +3681,6 @@ subroutine output_lsmOut_NWM(domainId) ! call the GetModelConfigType function modelConfigType = GetModelConfigType(nlst(1)%io_config_outputs) - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(myId .eq. 0) then ! We are on the I/O node. Create output file. write(output_flnm,'(A12,".LSMOUT_DOMAIN",I1)') nlst(domainId)%olddate(1:4)//& @@ -3828,6 +3694,8 @@ subroutine output_lsmOut_NWM(domainId) ! Write global attributes iret = nf90_put_att(ftn,NF90_GLOBAL,'TITLE',trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to place TITLE attribute into LSMOUT file.') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,'model_initialization_time',trim(fileMeta%initTime)) call nwmCheck(diagFlag,iret,'ERROR: Unable to place model init time attribute into LSMOUT file.') iret = nf90_put_att(ftn,NF90_GLOBAL,'model_output_valid_time',trim(fileMeta%validTime)) @@ -4038,13 +3906,6 @@ subroutine output_lsmOut_NWM(domainId) end if ! End if we are on the I/O processor. - ! Sync up all processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Allocate temporary local memory allocate(localRealTmp(rt_domain(domainId)%ix,rt_domain(domainId)%jx)) @@ -4059,13 +3920,6 @@ subroutine output_lsmOut_NWM(domainId) allocate(globalOutReal(1,1)) endif - ! Sync up processes - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Loop through the local array and convert floating point values ! to integer via scale_factor/add_offset. If the pixel value ! falls within a water class value, leave as ndv. @@ -4123,12 +3977,6 @@ subroutine output_lsmOut_NWM(domainId) enddo enddo ! Collect local 2D arrays to global 2D array - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif if(mppFlag .eq. 1) then #ifdef MPP_LAND call write_IO_real(localRealTmp,globalOutReal) @@ -4136,12 +3984,6 @@ subroutine output_lsmOut_NWM(domainId) else globalOutReal = localRealTmp endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif ! Write array out to NetCDF file if(myId .eq. 0) then @@ -4246,13 +4088,6 @@ subroutine output_frxstPts(domainId) gSize = rt_domain(domainId)%gnlinks endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(myId .eq. 0) then allocate(g_STRMFRXSTPTS(gSize)) allocate(g_outInd(gSize)) @@ -4282,13 +4117,6 @@ subroutine output_frxstPts(domainId) strFlowLocal = RT_DOMAIN(domainId)%QLINK(:,1) frxstPtsLocal = rt_domain(domainId)%STRMFRXSTPTS - ! Sync everything up before the next step. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Loop through all the local links on this processor. For lake_type ! of 2, we need to manually set the streamflow values ! to the model NDV value. @@ -4607,7 +4435,7 @@ subroutine output_chanObs_NWM(domainId) ! 0 means do not split = single output file single_output_file = nlst(domainId)%split_output_count .eq. 0 if(single_output_file) then - write(output_flnm,'("CHANOBS_DOMAIN",I1,".nc")'), nlst(domainId)%igrid + write(output_flnm,'("CHANOBS_DOMAIN",I1,".nc")') nlst(domainId)%igrid else write(output_flnm,'(A12,".CHANOBS_DOMAIN",I1)')nlst(domainId)%olddate(1:4)//& nlst(domainId)%olddate(6:7)//nlst(domainId)%olddate(9:10)//& @@ -4626,13 +4454,6 @@ subroutine output_chanObs_NWM(domainId) gSize = rt_domain(domainId)%gnlinks endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - if(myId .eq. 0) then allocate(g_STRMFRXSTPTS(gSize)) allocate(g_outInd(gSize)) @@ -4666,13 +4487,6 @@ subroutine output_chanObs_NWM(domainId) strFlowLocal = RT_DOMAIN(domainId)%QLINK(:,1) frxstPtsLocal = rt_domain(domainId)%STRMFRXSTPTS - ! Sync everything up before the next step. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Loop through all the local links on this processor. For lake_type ! of 2, we need to manually set the streamflow values ! to the model NDV value. @@ -4806,6 +4620,8 @@ subroutine output_chanObs_NWM(domainId) ! Write global attributes. iret = nf90_put_att(ftn,NF90_GLOBAL,"TITLE",trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create TITLE attribute') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"featureType",trim(fileMeta%fType)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create featureType attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"proj4",trim(fileMeta%proj4)) @@ -5325,12 +5141,6 @@ subroutine output_gw_NWM(domainId,iGrid) ! Collect and assemble local groundwater bucket arrays to a global array for ! output. if(mppFlag .eq. 1) then - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif if(myId .eq. 0) then allocate(g_qin_gwsubbas(rt_domain(domainId)%gnumbasns)) @@ -5396,13 +5206,6 @@ subroutine output_gw_NWM(domainId,iGrid) endif endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Calculate datetime information. ! First compose strings of EPOCH and simulation start date. epochDate = trim("1970-01-01 00:00") @@ -5471,6 +5274,8 @@ subroutine output_gw_NWM(domainId,iGrid) ! Write global attributes. iret = nf90_put_att(ftn,NF90_GLOBAL,"TITLE",trim(fileMeta%title)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create TITLE attribute') + iret = nf90_put_att(ftn,NF90_GLOBAL,"compiler_version",compiler_version()) + call nwmCheck(diagFlag,iret,'ERROR: Unable to create compiler_version attribute') iret = nf90_put_att(ftn,NF90_GLOBAL,"featureType",trim(fileMeta%fType)) call nwmCheck(diagFlag,iret,'ERROR: Unable to create featureType attribute') !iret = nf90_put_att(ftn,NF90_GLOBAL,"proj4",trim(fileMeta%proj4)) @@ -5661,13 +5466,6 @@ subroutine output_gw_NWM(domainId,iGrid) call nwmCheck(diagFlag,iret,'ERROR: Unable to close GWOUT file.') endif - ! Sync all processes up. - if(mppFlag .eq. 1) then -#ifdef MPP_LAND - call mpp_land_sync() -#endif - endif - ! Deallocate all memory if(myId .eq. 0) then deallocate(varOutReal) diff --git a/hydro/Routing/module_NWM_io_dict.F b/hydro/Routing/module_NWM_io_dict.F90 similarity index 99% rename from hydro/Routing/module_NWM_io_dict.F rename to hydro/Routing/module_NWM_io_dict.F90 index 81f62baa6c..3bbd388d66 100644 --- a/hydro/Routing/module_NWM_io_dict.F +++ b/hydro/Routing/module_NWM_io_dict.F90 @@ -1422,7 +1422,7 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 400.0d0, 400.0d0, 1.0d0, 1.0d0, 100000.0d0, & !51-55 1.0d0, 100.0d0, 100000.0d0, 100000.0d0, 400.0d0, & !56-60 1.0d0, 400.0d0, 1.0d0, 10000.0d0, 100000000.0d0, & !61-65 - 100.0d0, 10.0d0, 1.0d0, 100000.0d0, 100000.0d0, & !66-70 + 100.0d0, 10.0d0, 1.0d0, 1.0D+6, 100000.0d0, & !66-70 5.0d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0, & !71-76 5.0d0, 5.0d0, 5.0d0, 1000.0d0, 1000.0d0, & !76-80 1000.0d0, 1000.0d0, 5000.0d0, 5000.0d0, 1000.0d0, & !81-85 diff --git a/hydro/Routing/module_RT.F b/hydro/Routing/module_RT.F90 similarity index 100% rename from hydro/Routing/module_RT.F rename to hydro/Routing/module_RT.F90 diff --git a/hydro/Routing/module_UDMAP.F b/hydro/Routing/module_UDMAP.F90 similarity index 94% rename from hydro/Routing/module_UDMAP.F rename to hydro/Routing/module_UDMAP.F90 index 928656e10d..0b72a8eb0c 100644 --- a/hydro/Routing/module_UDMAP.F +++ b/hydro/Routing/module_UDMAP.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: ! This subrouting includs the data structure and tools used for NHDPlus network mapping. @@ -27,9 +27,9 @@ module module_UDMAP local_endx_rt,local_endy_rt, left_id, right_id, down_id, up_id, mpp_collect_1d_int_mem, & IO_id , numprocs use module_mpp_land, only: mpp_land_bcast_int, mpp_land_bcast_real8_1d, mpp_land_bcast_int1, mpp_land_bcast_int8 - + use module_mpp_land, only: sum_int1d, global_rt_nx, global_rt_ny, write_IO_rt_int, MPP_LAND_COM_INTEGER - + use MODULE_mpp_ReachLS, only : updatelinkv, ReachLS_write_io, com_write1dInt, & com_decomp1dInt, pack_decomp_int, pack_decomp_real8, & com_decomp1dint8, pack_decomp_int8, com_write1dInt8 @@ -92,9 +92,9 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) integer :: ix_bufid, ii, ixrt,jxrt integer, allocatable, dimension(:) :: gbufi,gbufj,bufsize real*8 , allocatable, dimension(:) :: gbufw - + did = 1 - call get_dimension(trim(nlst(did)%UDMAP_FILE), ndata, npid) + call get_dimension(trim(nlst(did)%UDMAP_FILE), ndata, npid) #ifdef MPP_LAND gnpid = npid @@ -110,10 +110,10 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) call get_nprocs_map(ixrt,jxrt,gbufi,gbufj,nprocs_map,ndata) if(my_id .eq. io_id) then - lnsizes = 0 + lnsizes = 0 do i =1 , ndata if(nprocs_map(i) .gt. 0) then - lnsizes(nprocs_map(i)) = lnsizes(nprocs_map(i)) + 1 + lnsizes(nprocs_map(i)) = lnsizes(nprocs_map(i)) + 1 endif enddo endif @@ -121,8 +121,8 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) if(my_id .eq. io_id ) then kk = 0 - do i = 1, numprocs - kk = kk + lnsizes(i) + do i = 1, numprocs + kk = kk + lnsizes(i) end do end if @@ -140,14 +140,14 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) if(lnsizes(my_id+1) .gt. 0) allocate(bufi(lnsizes(my_id+1) )) call pack_decomp_int(gbufi, ndata, nprocs_map, lnsizes, istart,bufi) - if(my_id .eq. io_id) then + if(my_id .eq. io_id) then if(allocated(gbufi)) deallocate(gbufi) endif - + if(lnsizes(my_id+1) .gt. 0) allocate(bufj(lnsizes(my_id+1) )) call pack_decomp_int(gbufj, ndata, nprocs_map, lnsizes, istart,bufj) - if(my_id .eq. io_id) then + if(my_id .eq. io_id) then if(allocated(gbufj)) deallocate(gbufj) endif @@ -186,7 +186,7 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) type(hash_t) :: hash_table integer(kind=int64) :: val,it logical :: found - + call hash_table%set_all_idx(bufid_tmp, ix_bufid) do it = 1, nlinksl call hash_table%get(linkid(it), val, found) @@ -214,21 +214,21 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) do k = 1, npid do j = 1, bufsize(k) g1bufid(i) = gbufid(k) - i = i + 1 + i = i + 1 end do enddo if(allocated(bufsize)) deallocate(bufsize) endif - if(my_id .eq. io_id) then + if(my_id .eq. io_id) then if(allocated(gbufid)) deallocate(gbufid) endif if(lnsizes(my_id+1) .gt. 0) allocate(bufid(lnsizes(my_id+1) )) call pack_decomp_int8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) - if(my_id .eq. io_id) then + if(my_id .eq. io_id) then if(allocated(g1bufid)) deallocate(g1bufid) endif @@ -239,7 +239,7 @@ subroutine readUDMP(ixrt,jxrt,npid, nlinksl) endif if(lnsizes(my_id+1) .gt. 0) allocate(bufw(lnsizes(my_id+1) )) call pack_decomp_real8(gbufw, ndata, nprocs_map, lnsizes, istart,bufw) - if(my_id .eq. io_id) then + if(my_id .eq. io_id) then if(allocated(gbufw)) deallocate(gbufw) endif @@ -269,12 +269,12 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) if(left_id .ge. 0) then starti = local_startx_rt + 1 else - starti = local_startx_rt + starti = local_startx_rt endif if(down_id .ge. 0) then startj = local_starty_rt + 1 else - startj = local_starty_rt + startj = local_starty_rt endif if(right_id .ge. 0) then endi = local_startx_rt + ix -2 @@ -294,7 +294,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) #endif gridflag = 0 lndflag = 0 - + #ifdef MPP_LAND k = 0 do i = 1, lnsize @@ -309,7 +309,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) lndflag(k) = lndflag(k) + 1 if(ter_rt_flag .eq. 1) then if(rtmask(bufi(i)-local_startx_rt+1,bufj(i)-local_starty_rt+1) .ge. 0) then - gridflag(k) = gridflag(k) + 1 + gridflag(k) = gridflag(k) + 1 endif endif endif @@ -324,20 +324,20 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) ! decide how many user defined links on current domain kk = k - LNUMRSL = 0 + LNUMRSL = 0 do k = 1, lnsize if(lndflag(k) .gt. 0) LNUMRSL = LNUMRSL + 1 enddo - if(LNUMRSL .gt. 0) then + if(LNUMRSL .gt. 0) then allocate(LUDRSL(LNUMRSL)) allocate( basns_area(LNUMRSL) ) else ! When MPI is performed,for every subdomain in each process, all the links ! are listed and if there is no link in the subdomain then it is calling -! cleanBuf (memory cleaning purposes), this used to print a warning +! cleanBuf (memory cleaning purposes), this used to print a warning ! that is not necessary for the user to see it, therefore it is been commented out here ! write(6,*) "Warning: no routing links found." call cleanBuf() @@ -345,7 +345,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) endif kk = 0 - do k = 1, lnsize + do k = 1, lnsize if( bufid(k) .ge. 0 ) then if (bufi(k) .ge. starti .and. bufj(k) .ge. startj .and. & bufi(k) .le. endi .and. bufj(k) .le. endj ) then @@ -354,7 +354,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) else if(bufid(k) .ne. bufid(k-1)) kk = kk + 1 endif - LUDRSL(kk)%myid = bufid(k) + LUDRSL(kk)%myid = bufid(k) LUDRSL(kk)%ngrids = -999 if(gridflag(kk) .gt. 0) then LUDRSL(kk)%ngrids = gridflag(kk) @@ -366,7 +366,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) endif endif ! define bucket variables - LUDRSL(kk)%ncell = lndflag(kk) + LUDRSL(kk)%ncell = lndflag(kk) if(.not. allocated(LUDRSL(kk)%cellweight) ) then allocate( LUDRSL(kk)%cellweight(LUDRSL(kk)%ncell)) allocate( LUDRSL(kk)%cell_i(LUDRSL(kk)%ncell)) @@ -382,25 +382,25 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) kk = 0 m = 1 c = 1 - do i = 1, lnsize - if( (bufid(i) .ge. 0) ) then + do i = 1, lnsize + if( (bufid(i) .ge. 0) ) then if(bufi(i) .ge. starti .and. bufj(i) .ge. startj .and. & bufi(i) .le. endi .and. bufj(i) .le. endj) then if(kk .eq. 0) then kk = 1 else - if(bufid(i) .ne. bufid(i-1)) then + if(bufid(i) .ne. bufid(i-1)) then kk = kk + 1 m = 1 c = 1 endif endif - if(LUDRSL(kk)%ngrids .gt. 0) then + if(LUDRSL(kk)%ngrids .gt. 0) then if(rtmask(bufi(i)-local_startx_rt+1,bufj(i)-local_starty_rt+1) .ge. 0) then LUDRSL(kk)%grid_i(m) = bufi(i) - local_startx_rt+1 LUDRSL(kk)%grid_j(m) = bufj(i) - local_starty_rt+1 - LUDRSL(kk)%weight(m) = bufw(i) + LUDRSL(kk)%weight(m) = bufw(i) m = m + 1 endif endif @@ -409,7 +409,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) LUDRSL(kk)%cell_j(c) = bufj(i) - local_starty_rt+1 LUDRSL(kk)%cellWeight(c) = bufw(i) c = c + 1 -!! end define bucket variables +!! end define bucket variables endif endif end do @@ -419,7 +419,7 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) #else call hydro_stop("FATAL ERROR in UDMP: Sequential not work.") #endif - + end subroutine UDMP2LOCAL subroutine cleanBuf() @@ -442,22 +442,22 @@ subroutine get_dimension(fileName, ndata,npid) trim(fileName) call hydro_stop("In get_dimension() - Problem opening mapping file.") endif - + iret = nf_inq_dimid(ncid, "polyid", dimid) - + if (iret /= 0) then print*, "nf_inq_dimid: polyid" call hydro_stop("In get_dimension() - nf_inq_dimid: polyid") endif - + iret = nf_inq_dimlen(ncid, dimid, npid) - + iret = nf_inq_dimid(ncid, "data", dimid) if (iret /= 0) then print*, "nf_inq_dimid: data" call hydro_stop("In get_file_dimension() - nf_inq_dimid: data") endif - + iret = nf_inq_dimlen(ncid, dimid, ndata) iret = nf_close(ncid) #ifdef MPP_LAND @@ -550,16 +550,16 @@ subroutine getUDMP_area(cell_area) do m = 1, LUDRSL(k)%ncell LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) enddo - - basns_area(k) = 0 + + basns_area(k) = 0 do m = 1, LUDRSL(k)%ncell basns_area(k) = basns_area(k) + & cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) enddo - + end do end subroutine getUDMP_area - + subroutine get_basn_area_nhd(inOut) implicit none real, dimension(:) :: inOut @@ -570,12 +570,12 @@ subroutine get_basn_area_nhd(inOut) inOut = basns_area #endif - + end subroutine get_basn_area_nhd subroutine get_nprocs_map(ix,jx,bufi,bufj,nprocs_map,ndata) implicit none - integer,dimension(:) :: bufi, bufj,nprocs_map + integer,dimension(:) :: bufi, bufj,nprocs_map ! integer, allocatable, dimension(:) :: lbufi,lbufj, lmap integer :: ndata, lsize, ix,jx integer, dimension(ix,jx) :: mask @@ -583,12 +583,12 @@ subroutine get_nprocs_map(ix,jx,bufi,bufj,nprocs_map,ndata) integer :: i,j,k, starti,startj, endi,endj, ii,jj, npid, kk #ifdef MPP_LAND - + mask = my_id + 1 if(my_id .eq. IO_id) allocate(gmask(global_rt_nx, global_rt_ny)) call MPP_LAND_COM_INTEGER(mask,IX,JX,99) - call write_IO_rt_int(mask, gmask) + call write_IO_rt_int(mask, gmask) if(my_id .eq. io_id ) then nprocs_map = -999 diff --git a/hydro/Routing/module_channel_routing.F b/hydro/Routing/module_channel_routing.F90 similarity index 99% rename from hydro/Routing/module_channel_routing.F rename to hydro/Routing/module_channel_routing.F90 index ff26557e4c..37f65cbce8 100644 --- a/hydro/Routing/module_channel_routing.F +++ b/hydro/Routing/module_channel_routing.F90 @@ -306,7 +306,7 @@ subroutine SUBMUSKINGCUNGE( & Km = dt endif - if ( (h_0 .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) .and. (Ck .gt. 0.0) ) then + if ( (h_0 .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) .and. (Ck .gt. 0.0) ) then !water outside of defined channel X = min(0.5,max(0.0,0.5*(1-(Qj_0/(2.0*TwCC*So*Ck*dx))))) else @@ -572,7 +572,7 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & NLINKSL, LINKID, node_area & #ifdef MPP_LAND , lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & - , LNLINKSL, LLINKID & + , LNLINKSL & , gtoNode,toNodeInd,nToNodeInd & #endif , CH_LNKRT_SL & @@ -633,8 +633,8 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & REAL, DIMENSION(NLINKS) :: dzGwChanHead REAL, DIMENSION(NLINKS) :: Q_GW_CHAN_FLUX !DJG !!! Change 'INTENT' to 'OUT' when ready to update groundwater state... REAL, DIMENSION(IXRT,JXRT) :: ZWATTBLRT !DJG !!! Match with subsfce/gw routing & Change 'INTENT' to 'INOUT' when ready to update groundwater state... - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: gwHead !DJG !!! groundwater head from Fersch-2d gw implementation...units (m ASL) - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: qgw_chanrt !DJG !!! Channel-gw flux as used in Fersch 2d gw implementation...units (m^3/s)...Change 'INTENT' to 'OUT' when ready to update groundwater state... + REAL, INTENT(INOUT), DIMENSION(:,:), allocatable :: gwHead !DJG !!! groundwater head from Fersch-2d gw implementation...units (m ASL) + REAL, INTENT(INOUT), DIMENSION(:,:), allocatable :: qgw_chanrt !DJG !!! Channel-gw flux as used in Fersch 2d gw implementation...units (m^3/s)...Change 'INTENT' to 'OUT' when ready to update groundwater state... @@ -671,7 +671,6 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & integer(kind=int64) link_location(ixrt,jxrt) real ywtmp(ixrt,jxrt) integer LNLINKSL - integer(kind=int64), dimension(LNLINKSL) :: LLINKID real*8, dimension(LNLINKSL) :: LQLateral ! real*4, dimension(LNLINKSL) :: LQLateral integer, dimension(:) :: toNodeInd diff --git a/hydro/Routing/module_date_utilities_rt.F b/hydro/Routing/module_date_utilities_rt.F90 similarity index 100% rename from hydro/Routing/module_date_utilities_rt.F rename to hydro/Routing/module_date_utilities_rt.F90 diff --git a/hydro/Routing/module_gw_gw2d.F b/hydro/Routing/module_gw_gw2d.F90 similarity index 97% rename from hydro/Routing/module_gw_gw2d.F rename to hydro/Routing/module_gw_gw2d.F90 index ccbf7cb523..7d663e7231 100644 --- a/hydro/Routing/module_gw_gw2d.F +++ b/hydro/Routing/module_gw_gw2d.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: !------------------------------------------------------------------------------ @@ -29,13 +29,11 @@ module module_gw_gw2d #ifdef MPP_LAND use module_mpp_land #endif - use module_gw_gw2d_data, only: gw2d + use module_gw_gw2d_data, only: gw2d, gw_field use module_rt_data, only: rt_domain use config_base, only: nlst - - implicit none -#include "gw_field_include.inc" + implicit none #ifdef MPP_LAND @@ -47,35 +45,35 @@ module module_gw_gw2d contains - + subroutine gw2d_ini(did,dt,dx) - + use module_HYDRO_io, only: output_gw_spinup - + implicit none integer did real dt,dx integer :: jj, ii, iter, itermax - - + + itermax = nlst(did)%GwPreCycles gw2d(did)%dx=dx gw2d(did)%dt=dt - + gw2d(did)%qgw_chanrt = 0. gw2d(did)%qsgwrt = 0. gw2d(did)%qdarcyRT = 0. gw2d(did)%excess = 0. - + gw2d(did)%compres=0. ! currently not implemented gw2d(did)%istep=0 ! initialize time step ! reset cells with undefined hydraulic conductivity where(gw2d(did)%hycond .eq. 100) gw2d(did)%hycond = 5E-4 - + do iter=1,itermax -#ifdef HYDRO_D +#ifdef HYDRO_D #ifdef MPP_LAND if(my_id .eq. IO_id) & #endif @@ -87,9 +85,9 @@ subroutine gw2d_ini(did,dt,dx) gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, gw2d(did)%excess, & gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & iter) - + gw2d(did)%ho = gw2d(did)%h - + if((nlst(did)%GwPreDiag .and. iter==1) .or. & nlst(did)%GwPreDiag .and. (mod(iter, nlst(did)%GwPreDiagInterval) .eq. 0) ) then call output_gw_spinup(nlst(did)%igrid, 1000000, & @@ -101,28 +99,28 @@ subroutine gw2d_ini(did,dt,dx) RT_DOMAIN(did)%LONVAL,rt_domain(did)%overland%properties%distance_to_neighbor, & nlst(did)%output_gw) end if - - + + end do return end subroutine gw2d_ini subroutine gw2d_allocate(did, ix, jx, nsoil) - + implicit none integer ix, jx, nsoil integer istatus, did - + if(gw2d(did)%allo_status .eq. 1) return gw2d(did)%allo_status = 1 - + gw2d(did)%ix = ix gw2d(did)%jx = jx - + #ifdef MPP_LAND if(down_id == -1) then ! if south border - gw2d(did)%jts = 1 + gw2d(did)%jts = 1 else gw2d(did)%jts = 2 endif @@ -164,8 +162,8 @@ subroutine gw2d_allocate(did, ix, jx, nsoil) allocate(gw2d(did)%excess (ix,jx)) allocate(gw2d(did)%qgw_chanrt (ix,jx)) - - + + ! TODO allocate only if gwSoilCoupling is active allocate(gw2d(did)%qsgwrt (ix,jx)) allocate(gw2d(did)%qsgw (rt_domain(did)%ix,rt_domain(did)%jx)) @@ -184,10 +182,10 @@ subroutine gwstep(ix, jx, dx, & ! New (volug): calling routines use change in head, convgw = d(h-ho)/dt. ! Steps ground-water hydrology (head) through one timestep. -! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer +! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer ! simulation program, with mods by Zhongbo Yu(1997). ! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources" -! for a single layer, where h is head, S is storage coeff and T is +! for a single layer, where h is head, S is storage coeff and T is ! transmissivity. 3-D arrays in main program (hycond,poros,h,bot) ! are 2-D here, since only a single (uppermost) layer is solved. ! Uses an iterative time-implicit ADI method. @@ -210,18 +208,18 @@ subroutine gwstep(ix, jx, dx, & real, intent(inout), dimension(ix,jx) :: & h, & ! head, after ghmcompute (m) (ret) convgw, & ! convergence due to gw flow (m/s) (ret) - excess + excess real, intent(inout) :: ebot, eocn - + integer :: istep !, dt real, intent(in) :: dt, dx -! #endif +! #endif ! eocn = mean spurious sink for h_ocn = sealev fix (m/s)(ret) -! This equals the total ground-water flow across +! This equals the total ground-water flow across ! land->ocean boundaries. ! ebot = mean spurious source for "bot" fix (m/s) (returned) ! time = elapsed time from start of run (sec) @@ -238,14 +236,14 @@ subroutine gwstep(ix, jx, dx, & bb, & ! tridiagonal matrix main diagonal cc, & ! tridiagonal matrix upper diagonal dd, & ! right hand side - b2, & - c2, & - rhs, & - wk, & - hh + b2, & + c2, & + rhs, & + wk, & + hh real, dimension(:), allocatable :: xfac, & zfac -#else +#else real, dimension(:), allocatable :: aa, & ! tridiagonal matrix lower diagonal bb, & ! tridiagonal matrix main diagonal cc, & ! tridiagonal matrix upper diagonal @@ -262,7 +260,7 @@ subroutine gwstep(ix, jx, dx, & integer :: its, ite, jts, jte, ifs, ife, jfs, jfe, & xdim, ydim, fxdim, fydim - + ! die müssen noch sortiert, geprüft und aufgeräumt werden integer :: & iter, & @@ -275,7 +273,7 @@ subroutine gwstep(ix, jx, dx, & ier, & ioffs, & joffs - + ! real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot real :: & dy, & @@ -310,7 +308,7 @@ subroutine gwstep(ix, jx, dx, & #ifdef MPP_LAND if(down_id == -1) then ! if south border - jts = 1 + jts = 1 else jts = 2 endif @@ -346,12 +344,12 @@ subroutine gwstep(ix, jx, dx, & jfe = jx -fxdim = ife-ifs+1 +fxdim = ife-ifs+1 fydim = jfe-jfs+1 - xdim = ite-its+1 + xdim = ite-its+1 ydim = jte-jts+1 - + call scopy (fxdim*fydim, ho(ifs:ife,jfs:jfe), 1, & h(ifs:ife,jfs:jfe), 1) @@ -364,7 +362,7 @@ subroutine gwstep(ix, jx, dx, & !~~~~~~~~~~~~~ iter = iter+1 - + #ifdef MPP_LAND call MPP_LAND_COM_REAL(h, fxdim, fydim, 99) @@ -375,8 +373,8 @@ subroutine gwstep(ix, jx, dx, & ! ebot = 0. ! accumulated fixes for h < bot (diagnostic) ! Set storage coefficient (sf2) - - + + tareal = 0. do j=jts,jte @@ -394,7 +392,7 @@ subroutine gwstep(ix, jx, dx, & ! su = poros(i,j)*(1.-theta(i,j)) ! old (pre-volug) su = poros(i,j) ! new (volug) sc = 1. - + ! if (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then sf2(i,j) = su ! else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then @@ -457,7 +455,7 @@ subroutine gwstep(ix, jx, dx, & call MPP_LAND_COM_REAL(t(:,:,1), fxdim, fydim, 99) call MPP_LAND_COM_REAL(t(:,:,2), fxdim, fydim, 99) - + allocate(aa(jts:jte,its:ite)) allocate(bb(jts:jte,its:ite)) allocate(cc(jts:jte,its:ite)) @@ -489,7 +487,7 @@ subroutine gwstep(ix, jx, dx, & aa(j) = 0.0 cc(j) = 0.0 - if ((j-jfs) /= 0) then + if ((j-jfs) /= 0) then aa(j) = -t(i,j-1,1) bb(j) = bb(j) + t(i,j-1,1) endif @@ -517,7 +515,7 @@ subroutine gwstep(ix, jx, dx, & h(i,:) = hh end do - + deallocate(aa) deallocate(bb) deallocate(cc) @@ -537,7 +535,7 @@ subroutine gwstep(ix, jx, dx, & aa(j,i) = 0.0 cc(j,i) = 0.0 - if (((j-jfs) /= 0)) then + if (((j-jfs) /= 0)) then aa(j,i) = -t(i,j-1,1) bb(j,i) = bb(j,i) + t(i,j-1,1) endif @@ -572,7 +570,7 @@ subroutine gwstep(ix, jx, dx, & c2, b2, hh, wk, xfac, zfac, & p_up_down+1, np_up_down, 2) - + call parysolv1(c2, b2, hh, 1., my_id+1, p_up_down+1, & xdim, ydim, np_left_right, np_up_down) @@ -594,11 +592,11 @@ subroutine gwstep(ix, jx, dx, & !>>>>>>>>>>>>>>>>>>>> h(i,j) = hh(j-joffs,i-ioffs) - + end do end do - -#endif + +#endif #ifdef MPP_LAND @@ -642,7 +640,7 @@ subroutine gwstep(ix, jx, dx, & call MPP_LAND_COM_REAL(t(:,:,2), fxdim, fydim, 99) #endif -#ifndef MPP_LAND +#ifndef MPP_LAND allocate(aa(ifs:ife)) allocate(bb(ifs:ife)) allocate(cc(ifs:ife)) @@ -667,7 +665,7 @@ subroutine gwstep(ix, jx, dx, & bb(i) = bb(i) + t(i,j-1,1) dd(i) = dd(i) + h(i,j-1)*t(i,j-1,1) endif - + if ((j-jfe) /= 0) then dd(i) = dd(i) + h(i,j+1)*t(i,j,1) bb(i) = bb(i) + t(i,j,1) @@ -691,7 +689,7 @@ subroutine gwstep(ix, jx, dx, & h(:,j) = hh end do - + #else !------------------- do i=its,ite @@ -709,7 +707,7 @@ subroutine gwstep(ix, jx, dx, & bb(j,i) = bb(j,i) + t(i,j-1,1) dd(j,i) = dd(j,i) + h(i,j-1)*t(i,j-1,1) endif - + if (((j-jfe) /= 0)) then dd(j,i) = dd(j,i) + h(i,j+1)*t(i,j,1) bb(j,i) = bb(j,i) + t(i,j,1) @@ -724,7 +722,7 @@ subroutine gwstep(ix, jx, dx, & bb(j,i) = bb(j,i) + t(i,j,2) cc(j,i) = -t(i,j,2) endif - + !>>>>>>>>>>>>>>> end do !>>>>>>>>>>>>>>> @@ -749,7 +747,7 @@ subroutine gwstep(ix, jx, dx, & dd, & c2, b2, hh, wk, xfac, zfac, & p_left_right+1, np_left_right, 1) - + call parxsolv1(c2, b2, hh, 1., my_id+1, p_left_right+1, & xdim, ydim, np_left_right, np_up_down) @@ -773,13 +771,13 @@ subroutine gwstep(ix, jx, dx, & end do end do - + deallocate(b2) deallocate(c2) deallocate(wk) deallocate(xfac) deallocate(zfac) -#endif +#endif deallocate(aa) deallocate(bb) deallocate(cc) @@ -787,7 +785,7 @@ subroutine gwstep(ix, jx, dx, & deallocate(hh) ! fix head < bottom of aquifer - + do j=jts,jte do i=its,ite if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then @@ -836,8 +834,8 @@ subroutine gwstep(ix, jx, dx, & ! if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax) & if ( (delcur.gt.delskip .and. iter.lt.itermax) & .or. iter.lt.itermin ) then - -#ifdef HYDRO_D + +#ifdef HYDRO_D #ifdef MPP_LAND if(my_id .eq. IO_id) write(6,*) "Iteration", iter, "of", itermax, "error:", delcur @@ -849,29 +847,29 @@ subroutine gwstep(ix, jx, dx, & goto 80 endif - + #ifdef MPP_LAND call MPP_LAND_COM_REAL(h, fxdim, fydim, 99) #endif - -! Compute exfiltration amount and -! convergence rate due to ground water + +! Compute exfiltration amount and +! convergence rate due to ground water ! flow do j=jts,jte do i=its,ite - + if((elev(i,j) - h(i,j)) .lt. 0.) then excess(i,j) = sf2(i,j)*(h(i,j) - elev(i,j)) h(i,j) = elev(i,j) - else + else excess(i,j) = 0. end if - + if(ltype(i,j).eq.1) then convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt else @@ -913,7 +911,7 @@ subroutine gwstep(ix, jx, dx, & call MPI_REDUCE(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) call MPI_REDUCE(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) call MPI_REDUCE(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - + if(my_id .eq. IO_id) then write (*,900) & gdtot*zz, gdtoa*zz, -geocn*zz, gebot*zz, & @@ -932,11 +930,11 @@ subroutine gwstep(ix, jx, dx, & ' ghmerror' & ! /3x,4f9.4,2(9x),e14.4) /3x,5(e14.4)) - + return end subroutine gwstep - - + + SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) ! ! Copies array ARR to BRR, incrementing by INCA and INCB @@ -955,11 +953,11 @@ SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) RETURN END SUBROUTINE SCOPY - + subroutine trdiagSolve(a,b,c,rhs,x,n) implicit none - + integer,intent(in) :: n real,dimension(n),intent(in) :: a, b, c, rhs real,dimension(n),intent(out) :: x @@ -982,26 +980,26 @@ subroutine trdiagSolve(a,b,c,rhs,x,n) do i = n-1, 1, -1 x(i) = dp(i)-cp(i)*x(i+1) end do - + end subroutine trdiagSolve - - + + subroutine gwSoilFlux(did) - + implicit none - + integer, intent(in) :: did - - + + real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt) :: smcrel, ztrans, headChange real :: frac, zres - integer :: nsoil, i, j, k - + integer :: nsoil, i, j, k + gw2d(did)%qsgwrt = 0. gw2d(did)%qdarcyRT = 0. - + ! Step 1, collect data ! relative soil moisture content of lowest soil layer (1 = saturated) @@ -1009,66 +1007,66 @@ subroutine gwSoilFlux(did) smcrel = rt_domain(did)%subsurface%grid_transform%smcrt(:,:,nsoil) / RT_DOMAIN(did)%subsurface%grid_transform%smcmaxrt(:,:,nsoil) ! depth of transition zone from lowest soil layer to groundwater head (in cm) -! postivie ztrans -> head below LSM soil layer +! postivie ztrans -> head below LSM soil layer ! negative ztrans -> head within LSM soil layers ztrans = (rt_domain(did)%elrt + nlst(did)%zsoil8(nsoil)) - gw2d(did)%ho ztrans = ztrans * 100 - + ! darcyGwSoil not defined for ztran = 0 where(ztrans == 0) ztrans = -5 - + ! Step 2, compute flux either up or down do j=gw2d(did)%jts, gw2d(did)%jte do i=gw2d(did)%its, gw2d(did)%ite - + if((ztrans(i,j) > 0) .and. (rt_domain(did)%soiltypRT(i,j) < 13)) then ! if groundwater head < soil layers call darcyGwSoil(ztrans(i,j), smcrel(i,j), rt_domain(did)%soiltypRT(i,j), gw2d(did)%qdarcyRT(i,j)) - + gw2d(did)%qsgwrt(i,j) = gw2d(did)%qdarcyRT(i,j) - + ! check and correct for mass balance if(((gw2d(did)%ho(i,j)-gw2d(did)%bot(i,j)) & *gw2d(did)%poros(i,j)) < (gw2d(did)%qsgwrt(i,j)*gw2d(did)%dt)) then - + gw2d(did)%qdarcyRT(i,j) = 0. gw2d(did)%qsgwrt(i,j) = 0. - + end if - + else if(ztrans(i,j) < 0 .and. (rt_domain(did)%soiltypRT(i,j) < 13)) then ! if groundwater head > soil layers zres = -ztrans(i,j) do k=nsoil,1,-1 - + if(zres >= rt_domain(did)%subsurface%properties%sldpth(k)*100.) then ! complete filling of a LSM soil layer if groundwater head > layer top - + ! gw2d(did)%qsgwrt(i,j) = (rt_domain(did)%subsurface%properties%sldpth(k) & ! * (rt_domain(did)%subsurface%grid_transform%smcmaxrt(i,j,k) - RT_DOMAIN(did)%subsurface%grid_transform%smcrt(i,j,k)) & ! + gw2d(did)%qsgwrt(i,j)) / gw2d(did)%dt - + rt_domain(did)%subsurface%grid_transform%smcrt(i,j,k) = RT_DOMAIN(did)%subsurface%grid_transform%smcmaxrt(i,j,k) - + zres = zres - rt_domain(did)%subsurface%properties%sldpth(k)*100. - + else ! partial filling of a soil layer if not completely below groundwater head - + if(zres > (0.5 * rt_domain(did)%subsurface%properties%sldpth(k)*100.)) then - + frac = zres / (rt_domain(did)%subsurface%properties%sldpth(k) * 100.) - - + + ! gw2d(did)%qsgwrt(i,j) = (rt_domain(did)%subsurface%properties%sldpth(k) & ! * (rt_domain(did)%subsurface%grid_transform%smcmaxrt(i,j,k) - RT_DOMAIN(did)%subsurface%grid_transform%smcrt(i,j,k)) & ! * frac + gw2d(did)%qsgwrt(i,j)) / gw2d(did)%dt - + rt_domain(did)%subsurface%grid_transform%smcrt(i,j,k) = RT_DOMAIN(did)%subsurface%grid_transform%smcmaxrt(i,j,k) * frac - + end if - + end if end do end if @@ -1081,15 +1079,15 @@ subroutine gwSoilFlux(did) ! TOcheck Step 3, adapt groundwater head (assuming not time lag for percolation / capillary rise flow) -! modify gw-head before gwstep call with respect to specific yield of the +! modify gw-head before gwstep call with respect to specific yield of the ! aquifer and the computed flux (qsgwrt) - + headChange = (-gw2d(did)%qdarcyRT) * gw2d(did)%dt / gw2d(did)%poros gw2d(did)%ho = gw2d(did)%ho + headChange - + end subroutine gwSoilFlux - + subroutine darcyGwSoil(Z, s, soil, q_darcy) implicit none @@ -1162,7 +1160,7 @@ end subroutine darcyGwSoil subroutine aggregateQsgw(did) - + implicit none @@ -1175,7 +1173,7 @@ subroutine aggregateQsgw(did) do i=1,rt_domain(did)%ix agg= 0. - + do m=nlst(did)%aggfactRT-1,0,-1 do n=nlst(did)%aggfactRT-1,0,-1 @@ -1183,7 +1181,7 @@ subroutine aggregateQsgw(did) ixxRT = i * nlst(did)%aggfactRT-n jyyRT = j * nlst(did)%aggfactRT-m - + #ifdef MPP_LAND if(left_id.ge.0) ixxRT=ixxRT+1 if(down_id.ge.0) jyyRT=jyyRT+1 @@ -1191,7 +1189,7 @@ subroutine aggregateQsgw(did) agg = agg + gw2d(did)%qdarcyRT(ixxRT, jyyRT) end do end do - + gw2d(did)%qsgw(i,j) = agg/(nlst(did)%aggfactRT**2) end do end do @@ -1219,16 +1217,16 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ZSPS, & XDNS, & ZDNS - + real, dimension(ZSPS, XSPS), intent(inout) :: c, & b real CLK_PER parameter (CLK_PER = 6.66666667e-9) real, dimension(0:ZSPS+1, 0:XSPS+1), intent(inout) :: r - + real, dimension(XSPS,2) :: zn, zntmp - + real, dimension(XSPS) :: t1, t2, fac real :: clockdt, click @@ -1237,7 +1235,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & integer :: pid, z_pid integer :: i, j, sndr_pid, msg_type, cnt, ackn integer :: sendReq, recvReq - + integer ZN_REC parameter (ZN_REC = 46) @@ -1247,7 +1245,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif cnt = 2*XSPS - + if (z_pid .eq. 1) then ! Load (ZSPS,j)th equations into passing arrays. @@ -1256,7 +1254,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & zntmp(j,2) = r(ZSPS,j) 10 continue - + #ifdef TIMING ti = click() #endif @@ -1376,10 +1374,10 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & r(i,j) = r(i,j) - b(i,j)*r(ZSPS,j) - c(i,j)*r(1,j) 70 continue 60 continue - + call mpi_wait(sendReq, mpp_status, ierr) - + else if (z_pid .lt. ZDNS) then #ifdef TIMING @@ -1427,7 +1425,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) call mpi_wait(sendReq, mpp_status, ierr) call mpi_wait(recvReq, mpp_status, ierr) - + #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1469,7 +1467,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & r(i,j) = r(i,j) - c(i,j)*r(1,j) - b(i,j)*r(ZSPS,j) 110 continue 100 continue - + call mpi_wait(sendReq, mpp_status, ierr) else @@ -1491,7 +1489,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) call mpi_wait(sendReq, mpp_status, ierr) call mpi_wait(recvReq, mpp_status, ierr) - + #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1534,15 +1532,15 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ZSPS, & XDNS, & ZDNS - + real, dimension(ZSPS, XSPS), intent(inout) :: c, & b - + real, dimension(0:ZSPS+1, 0:XSPS+1), intent(inout) :: r - + real, dimension(ZSPS,2) :: xn, xntmp - + integer XN_REC parameter (XN_REC = 45) @@ -1556,7 +1554,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & integer :: source, dest - + #ifdef TIMING dt = clockdt() #endif @@ -1679,7 +1677,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - + do 60 i = 1, ZSPS ! Backward elimination in (i,0)th equations. r(i,0) = t2(i) - t1(i)*r(i,1) @@ -1694,7 +1692,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & call mpi_wait(sendReq, mpp_status, ierr) - else if (x_pid .lt. XDNS) then + else if (x_pid .lt. XDNS) then cnt = 2*ZSPS #ifdef TIMING @@ -1772,7 +1770,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! Forward elimination in (i,XSPS)th equations to get -! r(i,XSPS+1). +! r(i,XSPS+1). do 100 i = 1, ZSPS r(i,XSPS+1) = t2(i) - t1(i)*r(i,XSPS) 100 continue @@ -1782,7 +1780,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & do 110 i = 1, ZSPS r(i,j) = r(i,j) - c(i,j)*r(i,1) - b(i,j)*r(i,XSPS) 110 continue - + call mpi_wait(sendReq, mpp_status, ierr) else @@ -1830,7 +1828,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & return end subroutine - + ! Parallel tridiagonal solver useful for domain decomposed ADI ! Author(s): Mike Lambert ! Year: 1996 @@ -1936,7 +1934,7 @@ subroutine sub_n_form(n_xs,n_zs,c,a,b,r,c2,b2,r2,wk,xfac,zfac, & r2(i,1) = (r2(i,1) - wk(i,1)*r2(i,2))*fac 100 continue - else + else do 110 i = 1, n_zs b2(i,n_xs-1) = wk(i,n_xs-1) @@ -2120,7 +2118,7 @@ subroutine sub_tri_solv(n_xs,n_zs,c,a,b,r,x,wk,xfac,zfac,dir) x(i,j) = x(i,j) - wk(i,j)*x(i,j+1) 30 continue - + else if (dir .eq. ZDIR) then do j = 1, n_xs @@ -2154,6 +2152,6 @@ subroutine sub_tri_solv(n_xs,n_zs,c,a,b,r,x,wk,xfac,zfac,dir) return end subroutine - - + + end module module_gw_gw2d diff --git a/hydro/Routing/module_lsm_forcing.F b/hydro/Routing/module_lsm_forcing.F90 similarity index 99% rename from hydro/Routing/module_lsm_forcing.F rename to hydro/Routing/module_lsm_forcing.F90 index 67c77a72bd..1006759629 100644 --- a/hydro/Routing/module_lsm_forcing.F +++ b/hydro/Routing/module_lsm_forcing.F90 @@ -3320,4 +3320,3 @@ subroutine read_forc_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain real, dimension(ix,jx):: infxsrt,soldrain call read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) end subroutine read_forc_ldasout_seq - diff --git a/hydro/Routing/module_noah_chan_param_init_rt.F b/hydro/Routing/module_noah_chan_param_init_rt.F90 similarity index 93% rename from hydro/Routing/module_noah_chan_param_init_rt.F rename to hydro/Routing/module_noah_chan_param_init_rt.F90 index b348d26b89..236d535b09 100644 --- a/hydro/Routing/module_noah_chan_param_init_rt.F +++ b/hydro/Routing/module_noah_chan_param_init_rt.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: MODULE module_noah_chan_param_init_rt @@ -32,7 +32,7 @@ SUBROUTINE CHAN_PARM_INIT (BOTWID,CHANN_K,HLINK_INIT,CHAN_SS,CHMann) integer :: IINDEX, CHANCATS integer :: ORDER, IUNIT - integer, PARAMETER :: NCHANTYPES=50 + integer, PARAMETER :: NCHANTYPES=50 real,dimension(NCHANTYPES) :: BOTWID,CHANN_K,TOPWID,HLINK_INIT,CHAN_SS,CHMann real,dimension(NCHANTYPES) :: TOPWIDCC, NCC character(LEN=11) :: DATATYPE @@ -46,7 +46,7 @@ SUBROUTINE CHAN_PARM_INIT (BOTWID,CHANN_K,HLINK_INIT,CHAN_SS,CHMann) ! NCC : mannings n of compound component ! HLINK_INIT: Initial depth of flow in channel (meters) ! CHAN_SS: Channel side slope (assuming trapezoidal channel geom) -! CHMann: Channel Manning's N roughness coefficient +! CHMann: Channel Manning's N roughness coefficient !-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL : @@ -79,9 +79,9 @@ SUBROUTINE CHAN_PARM_INIT (BOTWID,CHANN_K,HLINK_INIT,CHAN_SS,CHMann) ! TOPWIDCC(ORDER),NCC(ORDER) #ifdef HYDRO_D - PRINT *, IINDEX, BOTWID(ORDER), CHANN_K(ORDER), HLINK_INIT(ORDER), CHAN_SS(ORDER), & + PRINT *, IINDEX, BOTWID(ORDER), HLINK_INIT(ORDER), CHAN_SS(ORDER), & & CHMann(ORDER) -! PRINT *, IINDEX,BOTWID(ORDER),& +! PRINT *, IINDEX,BOTWID(ORDER),& ! HLINK_INIT(ORDER),CHAN_SS(ORDER), & ! CHMann(ORDER),TOPWIDCC(ORDER),NCC(ORDER) #endif @@ -107,7 +107,7 @@ SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,CHANN_K,HLINK_INIT,CHAN_SS,CHMann) implicit none integer :: IINDEX, CHANCATS integer :: ORDER - integer, PARAMETER :: NCHANTYPES=50 + integer, PARAMETER :: NCHANTYPES=50 real,dimension(NCHANTYPES) :: BOTWID,CHANN_K,HLINK_INIT,CHAN_SS,CHMann !real,dimension(NCHANTYPES) :: TOPWID, TOPWIDCC, NCC ! compound components character(LEN=11) :: DATATYPE @@ -125,7 +125,7 @@ SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,CHANN_K,HLINK_INIT,CHAN_SS,CHMann) ! call mpp_land_bcast_real(NCHANTYPES,TOPWIDCC) ! call mpp_land_bcast_real(NCHANTYPES,NCC) - return + return END SUBROUTINE mpp_CHAN_PARM_INIT #endif !----------------------------------------------------------------- diff --git a/hydro/Routing/module_reservoir_routing.F b/hydro/Routing/module_reservoir_routing.F90 similarity index 99% rename from hydro/Routing/module_reservoir_routing.F rename to hydro/Routing/module_reservoir_routing.F90 index cf367fcf0c..b2b20b459e 100644 --- a/hydro/Routing/module_reservoir_routing.F +++ b/hydro/Routing/module_reservoir_routing.F90 @@ -65,7 +65,7 @@ subroutine read_reservoir_obs(domainId) diagFlag = 0 #endif - ! Sync up processes. + ! Sync up processes. if(mppFlag .eq. 1) then #ifdef MPP_LAND call mpp_land_sync() @@ -75,7 +75,7 @@ subroutine read_reservoir_obs(domainId) ! Check to ensure the namelist option for reading in the reservoir discharge data ! has been set to 1. If not, return back to the main calling program. if(nlst(domainId)%reservoir_data_ingest .eq. 0) then - ! No reservoir realtime data requested. + ! No reservoir realtime data requested. return endif diff --git a/hydro/arc/Makefile.NoahMP b/hydro/arc/Makefile.NoahMP index 240e9d359d..6ea4fcb976 100644 --- a/hydro/arc/Makefile.NoahMP +++ b/hydro/arc/Makefile.NoahMP @@ -1,6 +1,7 @@ -# Makefile +# Makefile # CMD = Run/wrf_hydro.exe +.PHONY: $(CMD) all: $(CMD) @@ -24,16 +25,16 @@ $(CMD): (cd LandModel; make ) \ fi -debug:: - @echo 'F90FLAGS := $$(DEBUGFLAGS) $$(F90FLAGS)' >> ./macros +debug:: + @echo 'F90FLAGS := $$(DEBUGFLAGS) $$(F90FLAGS)' >> ./macros @echo 'F90FLAGS := $$(DEBUGFLAGS) $$(F90FLAGS)' >> ./LandModel/user_build_options debug:: $(CMD) install: - -rm -f ./Run/wrf_hydro.exe; \ + -rm -f ./Run/wrf_hydro.exe mv LandModel/run/hrldas.exe ./Run/wrf_hydro.exe test: - @echo "No libraries or utilities are built, skip testing." + @echo "No libraries or utilities are built, skip testing." clean: @if [ -d "LandModel_cpl" ]; then \ (cd LandModel_cpl; make clean) \ diff --git a/hydro/nudging/CMakeLists.txt b/hydro/nudging/CMakeLists.txt new file mode 100644 index 0000000000..c6e7b07b0f --- /dev/null +++ b/hydro/nudging/CMakeLists.txt @@ -0,0 +1,19 @@ +# build the version static library +add_library(hydro_nudging STATIC + module_date_utils_nudging.F90 + module_nudging_io.F90 + module_nudging_utils.F90 + module_stream_nudging.F90 +) + +target_link_libraries(hydro_nudging PRIVATE + hydro_mpp + hydro_data_rec + hydro_orchestrator +) + +target_include_directories(hydro_nudging + PRIVATE + ${netCDF_INCLUDE_DIRS} + ${netCDF-Fortran_INCLUDE_DIRS} +) diff --git a/hydro/nudging/Makefile b/hydro/nudging/Makefile index 3850014185..9580c7cf2a 100644 --- a/hydro/nudging/Makefile +++ b/hydro/nudging/Makefile @@ -1,7 +1,7 @@ -# Makefile +# Makefile # .SUFFIXES: -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros @@ -14,17 +14,17 @@ OBJS = \ all: $(OBJS) -#module_RT.o: module_RT.F +#module_RT.o: module_RT.F90 # @echo "" -# $(CPP) $(CPPFLAGS) $(*).F > $(*).f -# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f -# $(RMD) $(*).f +# $(CPP) $(CPPFLAGS) $(*).F90 > $(*).f90 +# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f90 +# $(RMD) $(*).f90 # @echo "" # cp *.mod ../mod -.F.o: +.F90.o: @echo "" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(NETCDF_INC) $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(NETCDF_INC) $(*).F90 @echo "" ar -r ../lib/libHYDRO.a $(@) cp *.mod ../mod diff --git a/hydro/nudging/module_date_utils_nudging.F b/hydro/nudging/module_date_utils_nudging.F90 similarity index 100% rename from hydro/nudging/module_date_utils_nudging.F rename to hydro/nudging/module_date_utils_nudging.F90 diff --git a/hydro/nudging/module_nudging_io.F b/hydro/nudging/module_nudging_io.F90 similarity index 90% rename from hydro/nudging/module_nudging_io.F rename to hydro/nudging/module_nudging_io.F90 index a3d8f33676..f29920ab8d 100644 --- a/hydro/nudging/module_nudging_io.F +++ b/hydro/nudging/module_nudging_io.F90 @@ -26,7 +26,6 @@ module module_nudging_io use module_hydro_stop, only: HYDRO_stop implicit none -#include !======================== ! lastObs structure, corresponding to nudgingLastObs.YYYY-mm-dd_HH:MM:ss.nc @@ -177,10 +176,10 @@ subroutine read_timeslice_file( & if (iRet /= nf90_NoErr) errStatus=errStatus+1 ! variables -call get_1d_netcdf_text(ncid, 'stationId', gageId, caller, & +call get_1d_netcdf(ncid, 'stationId', gageId, caller, & fatalErr, errStatusOut) errStatus=errStatus+errStatusOut -call get_1d_netcdf_text(ncid, 'time', gageTime, caller, & +call get_1d_netcdf(ncid, 'time', gageTime, caller, & fatalErr, errStatusOut) errStatus=errStatus+errStatusOut call get_1d_netcdf_real(ncid, 'discharge', gageDischarge, caller, & @@ -461,7 +460,7 @@ subroutine read_nudging_param_file( & call hydro_stop("read_nudging_param_file") endif -call get_1d_netcdf_text(ncid, 'stationId', gageId, caller, .TRUE., errStatus) +call get_1d_netcdf(ncid, 'stationId', gageId, caller, .TRUE., errStatus) call get_1d_netcdf_real(ncid, 'R', gageR, caller, .TRUE., errStatus) call get_1d_netcdf_real(ncid, 'G', gageG, caller, .TRUE., errStatus) call get_1d_netcdf_real(ncid, 'tau', gageTau, caller, .TRUE., errStatus) @@ -1201,7 +1200,6 @@ subroutine output_chan_connectivity( & #endif implicit none -#include !! These are the names used in module_HYDRO_io.F: SUBROUTINE READ_CHROUTING1 real, dimension(:), intent(in) :: inCHLAT, inCHLON, inCHANLEN @@ -1289,7 +1287,7 @@ subroutine output_chan_connectivity( & write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(nlst(did)%geo_finegrid_flnm) #endif - iret = nf_open(trim(nlst(1)%geo_finegrid_flnm), NF_NOWRITE, ncstatic) + iret = nf90_open(trim(nlst(1)%geo_finegrid_flnm), nf90_NOWRITE, ncstatic) if (iret /= 0) then write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & @@ -1302,15 +1300,15 @@ subroutine output_chan_connectivity( & if(projInfo_flag.eq.1) then !if/then hires_georef ! Get projection information from finegrid netcdf file - iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) + iret = nf90_inq_varid(ncstatic,'lambert_conformal_conic',varid) if(iret .eq. 0) & - iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) - iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) - iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) + iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm) + iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po) + iret = nf90_get_att(ncstatic, varid, 'false_easting', fe) + iret = nf90_get_att(ncstatic, varid, 'false_northing', fn) + iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp) end if !endif hires_georef - iret = nf_close(ncstatic) + iret = nf90_close(ncstatic) ! Create the channel connectivity file @@ -1333,119 +1331,119 @@ subroutine output_chan_connectivity( & #endif ! Dimension definitions - iret = nf_def_dim(ncid, "nStreamCells", nStreamCells, streamCellDimID) + iret = nf90_def_dim(ncid, "nStreamCells", nStreamCells, streamCellDimID) ! Variable definitions ! LATITUDE - float - iret = nf_def_var(ncid, "LATITUDE", NF_FLOAT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid,varid, 'long_name', 22, 'Upstream cell latitude') - iret = nf_put_att_text(ncid,varid, 'standard_name', 8, 'LATITUDE') - iret = nf_put_att_text(ncid,varid, 'units', 5, 'deg North') + iret = nf90_def_var(ncid, "LATITUDE", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid,varid, 'long_name', 'Upstream cell latitude') + iret = nf90_put_att(ncid,varid, 'standard_name', 'LATITUDE') + iret = nf90_put_att(ncid,varid, 'units', 'deg North') ! LONGITUDE - float - iret = nf_def_var(ncid, "LONGITUDE", NF_FLOAT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'long_name', 23, 'Upstream cell longitude') - iret = nf_put_att_text(ncid, varid, 'standard_name', 9, 'LONGITUDE') - iret = nf_put_att_text(ncid, varid, 'units', 8, 'deg East') + iret = nf90_def_var(ncid, "LONGITUDE", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'long_name', 'Upstream cell longitude') + iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE') + iret = nf90_put_att(ncid, varid, 'units', 'deg East') ! CHANLEN - float ! JLM: should check if pour points have chanLen, should they? - iret = nf_def_var(ncid, "CHANLEN", NF_FLOAT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 1,'m') - iret = nf_put_att_text(ncid, varid, 'long_name', 58, & + iret = nf90_def_var(ncid, "CHANLEN", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units','m') + iret = nf90_put_att(ncid, varid, 'long_name', & 'distance between stream cell center points with downstream') - iret = nf_put_att_real(ncid, varid, 'missing_value', NF_REAL, 1, -9E15) + iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) ! FROM_NODE - integer - iret = nf_def_var(ncid, "FROM_NODE", NF_INT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 5, 'index') - iret = nf_put_att_text(ncid, varid, 'long_name', 19, 'Upstream cell index') - iret = nf_put_att_int(ncid, varid, 'missing_value', NF_INT, 1, -9999) + iret = nf90_def_var(ncid, "FROM_NODE", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units', 'index') + iret = nf90_put_att(ncid, varid, 'long_name', 'Upstream cell index') + iret = nf90_put_att(ncid, varid, 'missing_value', -9999) ! TO_NODE - integer - iret = nf_def_var(ncid, "TO_NODE", NF_INT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 5, 'index') - iret = nf_put_att_text(ncid, varid, 'long_name', 21, 'Downstream cell index') - iret = nf_put_att_int(ncid, varid, 'missing_value', NF_INT, 1, -9999) + iret = nf90_def_var(ncid, "TO_NODE", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units', 'index') + iret = nf90_put_att(ncid, varid, 'long_name', 'Downstream cell index') + iret = nf90_put_att(ncid, varid, 'missing_value', -9999) ! CHANXI - integer - iret = nf_def_var(ncid, "CHANXI", NF_INT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 5, 'index') - iret = nf_put_att_text(ncid, varid, 'long_name', 34, 'Upstream cell x index on fine grid') - iret = nf_put_att_int(ncid, varid, 'missing_value', NF_INT, 1, -9999) + iret = nf90_def_var(ncid, "CHANXI", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units', 'index') + iret = nf90_put_att(ncid, varid, 'long_name', 'Upstream cell x index on fine grid') + iret = nf90_put_att(ncid, varid, 'missing_value', -9999) ! CHANYJ - integer - iret = nf_def_var(ncid, "CHANYJ", NF_INT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 5, 'index') - iret = nf_put_att_text(ncid, varid, 'long_name', 34, 'Upstream cell y index on fine grid') - iret = nf_put_att_int(ncid, varid, 'missing_value', NF_INT, 1, -9999) + iret = nf90_def_var(ncid, "CHANYJ", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units', 'index') + iret = nf90_put_att(ncid, varid, 'long_name', 'Upstream cell y index on fine grid') + iret = nf90_put_att(ncid, varid, 'missing_value', -9999) ! TYPEL - integer - iret = nf_def_var(ncid, "TYPEL", NF_INT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 5, 'code') - iret = nf_put_att_text(ncid, varid, 'long_name', 80, & + iret = nf90_def_var(ncid, "TYPEL", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units', 'code') + iret = nf90_put_att(ncid, varid, 'long_name', & 'Link Type 0 is channel 1 is pour point crit depth downstream 2 is reservoir lake') ! LAKENODE - integer - iret = nf_def_var(ncid, "LAKENODE", NF_INT, 1, (/ streamCellDimID /), varid) - iret = nf_put_att_text(ncid, varid, 'units', 5, 'index') - iret = nf_put_att_text(ncid, varid, 'long_name', 32, 'Index of lake in downstream cell') + iret = nf90_def_var(ncid, "LAKENODE", 1, (/ streamCellDimID /), varid) + iret = nf90_put_att(ncid, varid, 'units', 'index') + iret = nf90_put_att(ncid, varid, 'long_name', 'Index of lake in downstream cell') ! Projection information if(projInfo_flag .eq. 1) then - iret = nf_def_var(ncid, "lambert_conformal_conic", NF_INT, 0, 0, varid) - iret = nf_put_att_text(ncid, varid, 'grid_mapping_name', 23, 'lambert_conformal_conic') - iret = nf_put_att_real(ncid, varid, 'longitude_of_central_meridian', NF_FLOAT, 1, long_cm) - iret = nf_put_att_real(ncid, varid, 'latitude_of_projection_origin', NF_FLOAT, 1, lat_po) - iret = nf_put_att_real(ncid, varid, 'false_easting', NF_FLOAT, 1, fe) - iret = nf_put_att_real(ncid, varid, 'false_northing', NF_FLOAT, 1, fn) - iret = nf_put_att_real(ncid, varid, 'standard_parallel', NF_FLOAT, 2, sp) + iret = nf90_def_var(ncid, "lambert_conformal_conic", 0, 0, varid) + iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic') + iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm) + iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po) + iret = nf90_put_att(ncid, varid, 'false_easting', fe) + iret = nf90_put_att(ncid, varid, 'false_northing', fn) + iret = nf90_put_att(ncid, varid, 'standard_parallel', sp) end if ! End NCDF definition section - iret = nf_enddef(ncid) + iret = nf90_enddef(ncid) ! Put data in to the file ! Data for the dim? JLM: no, seems pointless index, if not necessary - !iret = nf_inq_varid(ncid,"nStreamCells", varid) - !iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), 1:nStreamCells - or however you) + !iret = nf90_inq_varid(ncid,"nStreamCells", varid) + !iret = nf90_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), 1:nStreamCells - or however you) ! Reals - iret = nf_inq_varid(ncid, "LATITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/ nStreamCells /), CHLAT) + iret = nf90_inq_varid(ncid, "LATITUDE", varid) + iret = nf90_put_var(ncid, varid, CHLAT, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "LONGITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/ nStreamCells /), CHLON) + iret = nf90_inq_varid(ncid, "LONGITUDE", varid) + iret = nf90_put_var(ncid, varid, CHLON, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "CHANLEN", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/ nStreamCells /), CHANLEN) + iret = nf90_inq_varid(ncid, "CHANLEN", varid) + iret = nf90_put_var(ncid, varid, CHANLEN, (/1/), (/ nStreamCells /)) ! Integers - iret = nf_inq_varid(ncid, "FROM_NODE", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), FROM_NODE) + iret = nf90_inq_varid(ncid, "FROM_NODE", varid) + iret = nf90_put_var(ncid, varid, FROM_NODE, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "TO_NODE", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), TO_NODE) + iret = nf90_inq_varid(ncid, "TO_NODE", varid) + iret = nf90_put_var(ncid, varid, TO_NODE, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "CHANXI", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), CHANXI) + iret = nf90_inq_varid(ncid, "CHANXI", varid) + iret = nf90_put_var(ncid, varid, CHANXI, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "CHANYJ", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), CHANYJ) + iret = nf90_inq_varid(ncid, "CHANYJ", varid) + iret = nf90_put_var(ncid, varid, CHANYJ, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "TYPEL", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), TYPEL) + iret = nf90_inq_varid(ncid, "TYPEL", varid) + iret = nf90_put_var(ncid, varid, TYPEL, (/1/), (/ nStreamCells /)) - iret = nf_inq_varid(ncid, "LAKENODE", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/ nStreamCells /), LAKENODE) + iret = nf90_inq_varid(ncid, "LAKENODE", varid) + iret = nf90_put_var(ncid, varid, LAKENODE, (/1/), (/ nStreamCells /)) ! Close the file - iret = nf_close(ncid) + iret = nf90_close(ncid) #ifdef MPP_LAND endif @@ -1562,7 +1560,7 @@ subroutine get_1d_netcdf_real(ncid, varName, var, callingRoutine, fatal_if_error end subroutine get_1d_netcdf_real -subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error, errStatus) +subroutine get_1d_netcdf(ncid, varName, var, callingRoutine, fatal_if_error, errStatus) implicit none character(len=*), dimension(:), intent(out) :: var integer, intent(in) :: ncid !! the file identifier @@ -1574,17 +1572,17 @@ subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error errStatus=0 iRet = nf90_inq_varid(ncid, varName, varid) if (iret /= nf90_NoErr) then - print*, trim(callingRoutine) // ": get_1d_netcdf_text: variable: " // trim(varName) - if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text") + print*, trim(callingRoutine) // ": get_1d_netcdf: variable: " // trim(varName) + if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf") errStatus=errStatus+1 end if iRet = nf90_get_var(ncid, varid, var) if (iret /= nf90_NoErr) then - print*, trim(callingRoutine) // ": get_1d_netcdf_text: values: " // trim(varName) - if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text") + print*, trim(callingRoutine) // ": get_1d_netcdf: values: " // trim(varName) + if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf") errStatus=errStatus+1 end if -end subroutine get_1d_netcdf_text +end subroutine get_1d_netcdf !============================================================================== diff --git a/hydro/nudging/module_nudging_utils.F b/hydro/nudging/module_nudging_utils.F90 similarity index 85% rename from hydro/nudging/module_nudging_utils.F rename to hydro/nudging/module_nudging_utils.F90 index 884a7234de..3afe2108af 100644 --- a/hydro/nudging/module_nudging_utils.F +++ b/hydro/nudging/module_nudging_utils.F90 @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: module module_nudging_utils @@ -33,22 +33,22 @@ module module_nudging_utils !=================================================================================================== -! Program Names: -! functions: whichPack and whichLoop -! Author(s)/Contact(s): +! Program Names: +! functions: whichPack and whichLoop +! Author(s)/Contact(s): ! James L McCreight -! Abstract: +! Abstract: ! Identify indices in a vector which are TRUE, reutrns zero length vector ! if there are no matches. -! History Log: +! History Log: ! 6/04/15 -Created, JLM. -! Usage: -! Parameters: +! Usage: +! Parameters: ! Input Files: -! Output Files: -! Condition codes: -! User controllable options: None. -! Notes: +! Output Files: +! Condition codes: +! User controllable options: None. +! Notes: ! JLM: Recent catastrophic failure reported for pack on ifort, with work arround. ! JLM: https://software.intel.com/en-us/forums/topic/559308#comments @@ -82,7 +82,7 @@ subroutine whichLoop(theMask, which, nWhich) which = -9999 return end if - if(theMask(ii)) then + if(theMask(ii)) then which(nWhich)=ii nWhich = nWhich + 1 endif @@ -91,22 +91,22 @@ subroutine whichLoop(theMask, which, nWhich) end subroutine whichLoop !=================================================================================================== -! Program Names: +! Program Names: ! function: whUnique -! Author(s)/Contact(s): +! Author(s)/Contact(s): ! James L McCreight -! Abstract: +! Abstract: ! Identify THE index in a logical vector which is TRUE. Returns ! -1 if not unique or none are true. -! History Log: +! History Log: ! 6/04/15 -Created, JLM. -! Usage: -! Parameters: +! Usage: +! Parameters: ! Input Files: -! Output Files: -! Condition codes: -! User controllable options: None. -! Notes: +! Output Files: +! Condition codes: +! User controllable options: None. +! Notes: function whUnique(theMask, unsafe) implicit none @@ -116,37 +116,37 @@ function whUnique(theMask, unsafe) integer, allocatable, dimension(:) :: whUniques integer :: i, nMatches if(present(unsafe)) then - !whUniques=pack( (/ (i, i=1,size(theMask)) /), mask= theMask) + !whUniques=pack( (/ (i, i=1,size(theMask)) /), mask= theMask) !whUnique = whUniques(1) - whUnique=sum( (/ (i, i=1,size(theMask)) /), mask= theMask) - else + whUnique=sum( (/ (i, i=1,size(theMask)) /), mask= theMask) + else nMatches = sum( (/ (1, i=1,size(theMask)) /), mask= theMask ) if (nMatches .gt. 1 .OR. nMatches .eq. 0) then whUnique=-1 - else - whUnique=sum( (/ (i, i=1,size(theMask)) /), mask= theMask) + else + whUnique=sum( (/ (i, i=1,size(theMask)) /), mask= theMask) end if end if end function whUnique !=================================================================================================== -! Program Names: +! Program Names: ! function: whUnique -! Author(s)/Contact(s): +! Author(s)/Contact(s): ! James L McCreight -! Abstract: +! Abstract: ! Simply returns the first match, no check for uniques. On gfortran this ! was the fastest of the bunch even/especially for max indices on huge arrays. -! History Log: +! History Log: ! 6/04/15 -Created, JLM. -! Usage: -! Parameters: +! Usage: +! Parameters: ! Input Files: -! Output Files: -! Condition codes: -! User controllable options: None. -! Notes: +! Output Files: +! Condition codes: +! User controllable options: None. +! Notes: function whUniLoop(theMask) implicit none @@ -163,21 +163,21 @@ function whUniLoop(theMask) end function whUniLoop !=================================================================================================== -! Program Names: +! Program Names: ! function: whInLoop -! Author(s)/Contact(s): +! Author(s)/Contact(s): ! James L McCreight -! Abstract: +! Abstract: ! Identify the indices of elements in a first vector which are present in the ! second vector, returns 0 for no matches. This can be slow, it's a double do/for loop. -! History Log: +! History Log: ! 6/04/15 -Created, JLM. -! Usage: -! Parameters: +! Usage: +! Parameters: ! Input Files: -! Output Files: -! Condition codes: -! User controllable options: None. +! Output Files: +! Condition codes: +! User controllable options: None. ! Notes: Can be slow, use with caution. ! parallelize this? |||||||||||||||||||||||||||||||||| @@ -222,26 +222,26 @@ end subroutine whichInLoop2 !=================================================================================================== -! Program Names: +! Program Names: ! accum_nudging_time -! Author(s)/Contact(s): +! Author(s)/Contact(s): ! James L McCreight -! Abstract: +! Abstract: ! Tally up the total cpu or wall time used by nudging. -! History Log: +! History Log: ! 8/20/15 -Created, JLM. -! Usage: -! Parameters: +! Usage: +! Parameters: ! start, end: real times for end-diff timing & accumulation ! sectionLabel: prints a message with the timing for the section ! print*, 'Ndg: ' // sectionLabel // '(seconds ' // trim(clockType) // ' time):', diff ! optional - accum: accumulate this towards the overall time or simply print the above ! message? Do not accum for nested sections of code, but still give the diagnostic. ! Input Files: -! Output Files: -! Condition codes: -! User controllable options: None. -! Notes: +! Output Files: +! Condition codes: +! User controllable options: None. +! Notes: subroutine accum_nudging_time(start, end, sectionLabel, accum) implicit none real, intent(in) :: start, end @@ -265,28 +265,28 @@ end subroutine accum_nudging_time !=================================================================================================== -! Program Names: +! Program Names: ! nudging_timer -! Author(s)/Contact(s): +! Author(s)/Contact(s): ! James L McCreight -! Abstract: +! Abstract: ! Return your choice of cpu time or wall time -! History Log: +! History Log: ! 8/20/15 -Created, JLM. -! Usage: -! Parameters: +! Usage: +! Parameters: ! Input Files: -! Output Files: -! Condition codes: -! User controllable options: None. -! Notes: +! Output Files: +! Condition codes: +! User controllable options: None. +! Notes: subroutine nudging_timer(time) implicit none real, intent(inout) :: time -integer :: count +integer :: count if(clockType.eq.'cpu') call cpu_time(time) if(clockType.eq.'wall') then - call system_clock(count=count) + call system_clock(count=count) time=real(count) end if end subroutine nudging_timer @@ -294,4 +294,3 @@ end subroutine nudging_timer !=================================================================================================== end module module_nudging_utils - diff --git a/hydro/nudging/module_stream_nudging.F b/hydro/nudging/module_stream_nudging.F90 similarity index 100% rename from hydro/nudging/module_stream_nudging.F rename to hydro/nudging/module_stream_nudging.F90 diff --git a/hydro/utils/CMakeLists.txt b/hydro/utils/CMakeLists.txt new file mode 100644 index 0000000000..923017f10d --- /dev/null +++ b/hydro/utils/CMakeLists.txt @@ -0,0 +1,20 @@ +# read version numbers for wrf_hydro_version and nwm_version from +# ../.version and ../.nwm_version files + +file(STRINGS "../.version" WRF_HYDRO_VERSION) +if(NWM_META AND EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/../.nwm_version) + file (STRINGS "../.nwm_version" NWM_VERSION) +else(NWM_META AND EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/../.nwm_version) + set(NWM_VERSION "undefined") +endif() + +# add the preprocessor definitions for NWM_VERSION and WRF_HYDRO_VERSION +# needed to compile module_version.F90 +add_definitions(-DNWM_VERSION="${NWM_VERSION}") +add_definitions(-DWRF_HYDRO_VERSION="${WRF_HYDRO_VERSION}") + +# build the version static library +add_library(hydro_utils STATIC + module_version.F90 + module_hydro_stop.F90 +) diff --git a/hydro/utils/Makefile b/hydro/utils/Makefile index 7fa0b82667..6110454da7 100644 --- a/hydro/utils/Makefile +++ b/hydro/utils/Makefile @@ -1,6 +1,6 @@ -# Makefile +# Makefile -.SUFFIXES: .o .F +.SUFFIXES: .o .F90 include ../macros @@ -19,9 +19,9 @@ OBJS = \ all: $(OBJS) ## The insertion of compile-time constants strangely requires the capital F in the extension. -.F.o: +.F90.o: @echo "Utils Makefile:" - $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).F + $(COMPILER90) $(CPPINVOKE) $(CPPFLAGS) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).F90 @echo "" ar -r ../lib/libHYDRO.a $(@) cp *.mod ../mod @@ -30,5 +30,5 @@ all: $(OBJS) # Dependencies: # -clean: +clean: rm -f *.o *.mod *.stb *~ diff --git a/hydro/utils/module_hydro_stop.F b/hydro/utils/module_hydro_stop.F90 similarity index 100% rename from hydro/utils/module_hydro_stop.F rename to hydro/utils/module_hydro_stop.F90 diff --git a/hydro/utils/module_version.F b/hydro/utils/module_version.F90 similarity index 100% rename from hydro/utils/module_version.F rename to hydro/utils/module_version.F90 diff --git a/inc/CMakeLists.txt b/inc/CMakeLists.txt new file mode 100644 index 0000000000..afae9a9632 --- /dev/null +++ b/inc/CMakeLists.txt @@ -0,0 +1,13 @@ +get_filename_component( FOLDER_COMPILE_TARGET ${CMAKE_CURRENT_SOURCE_DIR} NAME) +set( + WRF_INCLUDE_FILES + intio_tags.h + streams.h + version_decl + ${PROJECT_BINARY_DIR}/inc/commit_decl + ) + +install( + FILES ${WRF_INCLUDE_FILES} + DESTINATION include/inc/${FOLDER_COMPILE_TARGET} + ) \ No newline at end of file diff --git a/inc/intio_tags.h b/inc/intio_tags.h index 3808968cf5..daa130ef5f 100644 --- a/inc/intio_tags.h +++ b/inc/intio_tags.h @@ -1,34 +1,34 @@ - INTEGER, PARAMETER :: int_ioexit = 10 - INTEGER, PARAMETER :: int_open_for_write_begin = 20 - INTEGER, PARAMETER :: int_open_for_write_commit = 30 - INTEGER, PARAMETER :: int_open_for_read = 40 - INTEGER, PARAMETER :: int_inquire_opened = 60 - INTEGER, PARAMETER :: int_inquire_filename = 70 - INTEGER, PARAMETER :: int_iosync = 80 - INTEGER, PARAMETER :: int_ioclose = 90 - INTEGER, PARAMETER :: int_next_time = 100 - INTEGER, PARAMETER :: int_set_time = 110 - INTEGER, PARAMETER :: int_next_var = 120 - INTEGER, PARAMETER :: int_dom_ti_real = 140 - INTEGER, PARAMETER :: int_dom_ti_double = 160 - INTEGER, PARAMETER :: int_dom_ti_integer = 180 - INTEGER, PARAMETER :: int_dom_ti_logical = 200 - INTEGER, PARAMETER :: int_dom_ti_char = 220 - INTEGER, PARAMETER :: int_dom_td_real = 240 - INTEGER, PARAMETER :: int_dom_td_double = 260 - INTEGER, PARAMETER :: int_dom_td_integer = 280 - INTEGER, PARAMETER :: int_dom_td_logical = 300 - INTEGER, PARAMETER :: int_dom_td_char = 320 - INTEGER, PARAMETER :: int_var_ti_real = 340 - INTEGER, PARAMETER :: int_var_ti_double = 360 - INTEGER, PARAMETER :: int_var_ti_integer = 380 - INTEGER, PARAMETER :: int_var_ti_logical = 400 - INTEGER, PARAMETER :: int_var_ti_char = 420 - INTEGER, PARAMETER :: int_var_td_real = 440 - INTEGER, PARAMETER :: int_var_td_double = 460 - INTEGER, PARAMETER :: int_var_td_integer = 480 - INTEGER, PARAMETER :: int_var_td_logical = 500 - INTEGER, PARAMETER :: int_var_td_char = 520 - INTEGER, PARAMETER :: int_field = 530 - INTEGER, PARAMETER :: int_var_info = 540 - INTEGER, PARAMETER :: int_noop = 550 +#define INT_IOEXIT 10 +#define INT_OPEN_FOR_WRITE_BEGIN 20 +#define INT_OPEN_FOR_WRITE_COMMIT 30 +#define INT_OPEN_FOR_READ 40 +#define INT_INQUIRE_OPENED 60 +#define INT_INQUIRE_FILENAME 70 +#define INT_IOSYNC 80 +#define INT_IOCLOSE 90 +#define INT_NEXT_TIME 100 +#define INT_SET_TIME 110 +#define INT_NEXT_VAR 120 +#define INT_DOM_TI_REAL 140 +#define INT_DOM_TI_DOUBLE 160 +#define INT_DOM_TI_INTEGER 180 +#define INT_DOM_TI_LOGICAL 200 +#define INT_DOM_TI_CHAR 220 +#define INT_DOM_TD_REAL 240 +#define INT_DOM_TD_DOUBLE 260 +#define INT_DOM_TD_INTEGER 280 +#define INT_DOM_TD_LOGICAL 300 +#define INT_DOM_TD_CHAR 320 +#define INT_VAR_TI_REAL 340 +#define INT_VAR_TI_DOUBLE 360 +#define INT_VAR_TI_INTEGER 380 +#define INT_VAR_TI_LOGICAL 400 +#define INT_VAR_TI_CHAR 420 +#define INT_VAR_TD_REAL 440 +#define INT_VAR_TD_DOUBLE 460 +#define INT_VAR_TD_INTEGER 480 +#define INT_VAR_TD_LOGICAL 500 +#define INT_VAR_TD_CHAR 520 +#define INT_FIELD 530 +#define INT_VAR_INFO 540 +#define INT_NOOP 550 diff --git a/inc/version_decl b/inc/version_decl index 98f1ed2596..6cfe90eaba 100644 --- a/inc/version_decl +++ b/inc/version_decl @@ -1 +1 @@ - CHARACTER (LEN=*), PARAMETER :: release_version = 'V4.5.1' + CHARACTER (LEN=*), PARAMETER :: release_version = 'V4.6.0' diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt new file mode 100644 index 0000000000..9a2f69eca6 --- /dev/null +++ b/main/CMakeLists.txt @@ -0,0 +1,153 @@ +# WRF CMake Build +set( FOLDER_COMPILE_TARGETS ) + +# First make true executables +if ( ${WRF_CORE} STREQUAL "PLUS" ) + add_executable( + wrfplus + wrf.F + module_wrf_top.F + ) + list( APPEND FOLDER_COMPILE_TARGETS wrfplus ) +else() + # I believe this is always made if not WRF PLUS or ESMF + add_executable( + wrf + wrf.F + module_wrf_top.F + ) + list( APPEND FOLDER_COMPILE_TARGETS wrf ) +# #!TODO When does this get activated? +# elseif() +# add_executable( +# wrf_SST_ESMF +# wrf_ESMFMod.F +# wrf_SST_ESMF.F +# module_wrf_top.F +# ) +# list( APPEND FOLDER_COMPILE_TARGETS em_wrf_SST_ESMF ) +endif() + +# Use case info from higher CMakeLists.txt +set( MODULE_FILE ${PROJECT_SOURCE_DIR}/dyn_em/module_initialize_${WRF_CASE_MODULE}.F ) + +if ( ${WRF_CASE} STREQUAL "EM_REAL" ) + add_executable( + ndown + ndown_em.F + ${MODULE_FILE} + ) + add_executable( + tc + tc_em.F + ${MODULE_FILE} + ) + add_executable( + real + real_em.F + ${MODULE_FILE} + ) + list( APPEND FOLDER_COMPILE_TARGETS ndown tc real ) + +elseif( NOT ${WRF_GENERAL_IDEAL_CASE} ) # Not general ideal and not real + # All others are variants of ideal + add_executable( + ideal + ideal_em.F + ${MODULE_FILE} + ) + list( APPEND FOLDER_COMPILE_TARGETS ideal ) +else() + # greater than or equal to general ideal case + add_executable( + ideal + ideal_em.F + ${PROJECT_SOURCE_DIR}/dyn_em/module_initialize_ideal.F + ) + list( APPEND FOLDER_COMPILE_TARGETS ideal ) +endif() + + +foreach ( TARGET ${FOLDER_COMPILE_TARGETS} ) + set_target_properties( + ${TARGET} + PROPERTIES + # Just dump everything in here + Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/modules/${TARGET}/ + Fortran_FORMAT FREE + ) + + + if ( ${USE_IPO} ) + set_target_properties( + ${TARGET} + PROPERTIES + INTERPROCEDURAL_OPTIMIZATION TRUE + ) + + if ( ${CMAKE_VERSION} VERSION_LESS 3.24 ) + target_link_libraries( + ${TARGET} + PRIVATE + ${PROJECT_NAME}_Core + ) + + # Static libraries with LTO/IPO sometimes don't pull all the correct symbols + set( LINKER_OPTION ${CMAKE_Fortran_LINKER_WRAPPER_FLAG} ) + target_link_options( + ${TARGET} + PRIVATE + ${LINKER_OPTION}--whole-archive $ ${LINKER_OPTION}--no-whole-archive + ) + else() + target_link_libraries( + ${TARGET} + PRIVATE + $ + ) + endif() + else() + target_link_libraries( + ${TARGET} + PRIVATE + ${PROJECT_NAME}_Core + ) + endif() + + target_include_directories( + ${TARGET} + PRIVATE + ${PROJECT_SOURCE_DIR}/inc + ${PROJECT_BINARY_DIR}/inc + $ + ) +endforeach() + + +install( + TARGETS ${FOLDER_COMPILE_TARGETS} + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) + +# Install the "run" directory +install( + DIRECTORY ${PROJECT_SOURCE_DIR}/run/ + DESTINATION ${CMAKE_INSTALL_PREFIX}/run + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ${FOLDER_COMPILE_TARGETS} + DEST_PATH ${CMAKE_INSTALL_PREFIX}/run + USE_SYMLINKS + ) + +# Re-setup this particular file +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/phys/noahmp/parameters/MPTABLE.TBL + DEST_PATH + ${CMAKE_INSTALL_PREFIX}/run/ + ) diff --git a/main/depend.common b/main/depend.common index 6547de9916..a19a778c51 100644 --- a/main/depend.common +++ b/main/depend.common @@ -1,1344 +1,2859 @@ # DEPENDENCIES for frame - module_configure.o: \ - ../dyn_em/namelist_remappings_em.h \ - module_domain_type.o \ - module_state_description.o \ - module_wrf_error.o \ - module_driver_constants.o - -module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \ - module_domain.o \ - module_driver_constants.o \ - module_timing.o \ - module_comm_nesting_dm.o \ - module_configure.o module_comm_dm.o \ - module_cpl.o \ - ../share/module_model_constants.o + ../dyn_em/namelist_remappings_em.h \ + module_domain_type.o \ + module_state_description.o \ + module_wrf_error.o \ + module_driver_constants.o + + +module_dm.o: \ + module_machine.o \ + module_state_description.o \ + module_wrf_error.o \ + module_domain.o \ + module_driver_constants.o \ + module_timing.o \ + module_comm_nesting_dm.o \ + module_configure.o \ + module_comm_dm.o \ + module_cpl.o \ + ../share/module_model_constants.o + + +module_timing.o: \ + module_wrf_error.o \ + hires_timer.o \ + clog.o + + +module_comm_dm.o: \ + module_configure.o \ + module_domain.o \ + module_driver_constants.o \ + module_comm_dm_0.o \ + module_comm_dm_1.o \ + module_comm_dm_2.o \ + module_comm_dm_3.o \ + module_comm_dm_4.o + -module_timing.o: hires_timer.o clog.o +module_comm_dm_0.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o -module_comm_dm.o: module_comm_dm_0.o module_comm_dm_1.o module_comm_dm_2.o module_comm_dm_3.o module_comm_dm_4.o -module_comm_dm_0.o: module_domain.o module_configure.o -module_comm_dm_1.o: module_domain.o module_configure.o -module_comm_dm_2.o: module_domain.o module_configure.o -module_comm_dm_3.o: module_domain.o module_configure.o -module_comm_dm_4.o: module_domain.o module_configure.o +module_comm_dm_1.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_2.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_3.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_comm_dm_4.o: \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o + module_comm_nesting_dm.o: \ - module_domain.o \ - module_configure.o - -module_dm_stubs.F: module_domain.o - -module_domain.o: module_domain_type.o \ - module_alloc_space_0.o \ - module_alloc_space_1.o \ - module_alloc_space_2.o \ - module_alloc_space_3.o \ - module_alloc_space_4.o \ - module_alloc_space_5.o \ - module_alloc_space_6.o \ - module_alloc_space_7.o \ - module_alloc_space_8.o \ - module_alloc_space_9.o \ - module_driver_constants.o \ - module_configure.o \ - module_machine.o \ - module_state_description.o \ - module_wrf_error.o \ - $(ESMF_MOD_DEPENDENCE) - -module_domain_type.o : module_driver_constants.o module_streams.o $(ESMF_MOD_DEPENDENCE) - -module_alloc_space_0.o : module_domain_type.o module_configure.o -module_alloc_space_1.o : module_domain_type.o module_configure.o -module_alloc_space_2.o : module_domain_type.o module_configure.o -module_alloc_space_3.o : module_domain_type.o module_configure.o -module_alloc_space_4.o : module_domain_type.o module_configure.o -module_alloc_space_5.o : module_domain_type.o module_configure.o -module_alloc_space_6.o : module_domain_type.o module_configure.o -module_alloc_space_7.o : module_domain_type.o module_configure.o -module_alloc_space_8.o : module_domain_type.o module_configure.o -module_alloc_space_9.o : module_domain_type.o module_configure.o - -module_streams.o : \ - module_state_description.o + module_driver_constants.o \ + module_domain.o \ + module_configure.o + + +module_dm_stubs.F: \ + module_domain.o + + +module_domain.o: \ + module_domain_type.o \ + module_alloc_space_0.o \ + module_alloc_space_1.o \ + module_alloc_space_2.o \ + module_alloc_space_3.o \ + module_alloc_space_4.o \ + module_alloc_space_5.o \ + module_alloc_space_6.o \ + module_alloc_space_7.o \ + module_alloc_space_8.o \ + module_alloc_space_9.o \ + module_driver_constants.o \ + module_configure.o \ + module_machine.o \ + module_state_description.o \ + module_wrf_error.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_domain_type.o: \ + module_driver_constants.o \ + module_streams.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_alloc_space_0.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_1.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_2.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_3.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_4.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_5.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_6.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_7.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_8.o: \ + module_domain_type.o \ + module_configure.o + + +module_alloc_space_9.o: \ + module_domain_type.o \ + module_configure.o + + +module_streams.o: \ + module_state_description.o + module_driver_constants.o: \ - module_state_description.o \ - module_wrf_error.o + module_state_description.o \ + module_wrf_error.o + module_integrate.o: \ - module_domain.o \ - module_timing.o \ - module_driver_constants.o \ - module_state_description.o \ - module_nesting.o \ - module_configure.o \ - $(LLIST) \ - module_cpl.o \ - module_dm.o \ - $(ESMF_MOD_DEPENDENCE) + module_domain.o \ + module_timing.o \ + module_driver_constants.o \ + module_state_description.o \ + module_nesting.o \ + module_configure.o \ + $(LLIST) \ + module_cpl.o \ + module_dm.o \ + $(ESMF_MOD_DEPENDENCE) + module_intermediate_nmm.o: \ - module_state_description.o \ - module_domain.o \ - module_configure.o \ - module_dm.o \ - module_comm_dm.o \ - module_timing.o - -module_io.o : md_calls.inc \ - module_dm.o \ - module_state_description.o \ - module_configure.o \ - module_streams.o \ - module_driver_constants.o + module_state_description.o \ + module_domain.o \ + module_configure.o \ + module_dm.o \ + module_comm_dm.o \ + module_timing.o + + +module_io.o: \ + module_domain.o \ + md_calls.inc \ + module_dm.o \ + module_state_description.o \ + module_configure.o \ + module_streams.o \ + module_driver_constants.o + module_io_quilt.o: \ - module_state_description.o \ - module_dm.o \ - module_configure.o \ - module_internal_header_util.o \ - module_quilt_outbuf_ops.o \ - module_wrf_error.o \ - module_cpl.o + module_state_description.o \ + module_dm.o \ + module_configure.o \ + module_internal_header_util.o \ + module_quilt_outbuf_ops.o \ + module_wrf_error.o \ + module_cpl.o + module_machine.o: \ - module_driver_constants.o + module_driver_constants.o + module_nesting.o: \ - module_machine.o \ - module_driver_constants.o \ - module_configure.o \ - $(ESMF_MOD_DEPENDENCE) \ - module_domain.o + module_machine.o \ + module_driver_constants.o \ + module_configure.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_domain.o + module_quilt_outbuf_ops.o: \ - module_state_description.o module_timing.o - -module_tiles.o: module_domain.o \ - module_driver_constants.o \ - module_machine.o \ - module_configure.o \ - module_wrf_error.o - + module_state_description.o \ + module_timing.o + + +module_tiles.o: \ + module_domain.o \ + module_driver_constants.o \ + module_machine.o \ + module_configure.o \ + module_wrf_error.o + + module_timing.o: \ - module_state_description.o \ - module_wrf_error.o + module_state_description.o \ + module_wrf_error.o + module_wrf_error.o: \ - wrf_shutdown.o \ - clog.o \ - $(ESMF_MOD_DEPENDENCE) + wrf_shutdown.o \ + clog.o \ + $(ESMF_MOD_DEPENDENCE) + wrf_debug.o: \ - module_wrf_error.o + module_wrf_error.o + + +module_sm.o: \ + module_wrf_error.o -module_sm.o: module_wrf_error.o module_cpl.o: \ - ../share/module_model_constants.o \ - module_driver_constants.o \ - module_domain.o \ - module_configure.o \ - module_cpl_oasis3.o + ../share/module_model_constants.o \ + module_driver_constants.o \ + module_domain.o \ + module_configure.o \ + module_cpl_oasis3.o + -module_cpl_oasis3.o: module_driver_constants.o \ - module_domain.o +module_cpl_oasis3.o: \ + module_driver_constants.o \ + module_domain.o -module_clear_halos.o: module_configure.o \ - module_domain.o + +module_clear_halos.o: \ + module_configure.o \ + module_domain.o \ # End of DEPENDENCIES for frame # DEPENDENCIES for phys -module_madwrf.o: ../share/module_model_constants.o \ - ../share/module_soil_pre.o \ - ../phys/module_mp_thompson.o +module_madwrf.o: \ + module_wrf_top.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + module_mp_thompson.o -module_bl_myjpbl.o: ../share/module_model_constants.o -module_bl_myjurb.o: ../share/module_model_constants.o +module_bl_ysu.o: \ + ccpp_kind_types.o \ + physics_mmm/bl_ysu.o + -module_bl_gbmpbl.o: ../share/module_model_constants.o +module_bl_myjpbl.o: \ + ../share/module_model_constants.o -module_bl_boulac.o: ../share/module_model_constants.o -module_bl_qnsepbl.o: ../share/module_model_constants.o +module_bl_myjurb.o: \ + ../share/module_model_constants.o -module_progtm.o: module_gfs_machine.o -module_bl_gfs.o: module_gfs_machine.o \ - module_gfs_physcons.o +module_bl_gbmpbl.o: \ + ../share/module_model_constants.o -module_bl_gfsedmf.o: module_gfs_machine.o \ - module_gfs_physcons.o -module_bl_mynn.o: module_bl_mynn_common.o +module_bl_boulac.o: \ + ../share/module_model_constants.o -module_bl_mynn_wrapper.o: module_bl_mynn.o \ - module_bl_mynn_common.o -module_cam_upper_bc.o: module_cam_shr_kind_mod.o \ - module_cam_support.o +module_bl_qnsepbl.o: \ + ../share/module_model_constants.o -module_cam_constituents.o: module_cam_shr_kind_mod.o \ - module_cam_physconst.o \ - module_cam_support.o \ - ../frame/module_wrf_error.o -module_cam_trb_mtn_stress.o: module_cam_shr_kind_mod.o \ - module_cam_support.o +module_progtm.o: \ + module_gfs_machine.o -module_cam_molec_diff.o: module_cam_support.o \ - module_cam_constituents.o \ - module_cam_upper_bc.o -module_data_cam_mam_aero.o : module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_mp_radconstants.o +module_bl_gfs.o: \ + module_gfs_machine.o \ + module_gfs_physcons.o -module_data_cam_mam_asect.o : module_cam_shr_kind_mod.o \ - module_data_cam_mam_aero.o -module_cam_bl_diffusion_solver.o: module_cam_support.o +module_bl_gfsedmf.o: \ + module_gfs_machine.o \ + module_gfs_physcons.o -module_cam_bl_eddy_diff.o:module_cam_bl_diffusion_solver.o \ - module_cam_support.o -module_bl_camuwpbl_driver.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_constituents.o \ - module_cam_bl_diffusion_solver.o\ - module_cam_physconst.o \ - module_cam_trb_mtn_stress.o \ - module_cam_bl_eddy_diff.o \ - module_cam_wv_saturation.o \ - module_cam_molec_diff.o \ - module_data_cam_mam_aero.o \ - ../share/module_model_constants.o \ - module_cam_esinti.o +module_bl_mynn.o: \ + module_bl_mynn_common.o -module_sf_mynn.o: module_sf_sfclay.o module_bl_mynn.o \ - ../share/module_model_constants.o \ - ../frame/module_wrf_error.o -module_sf_fogdes.o: ../share/module_model_constants.o +module_bl_mynn_wrapper.o: \ + module_bl_mynn.o \ + module_bl_mynn_common.o -module_bl_fogdes.o: ../share/module_model_constants.o -module_sf_gfdl.o : \ - module_gfs_machine.o \ - module_sf_exchcoef.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o +module_bl_gwdo.o: \ + physics_mmm/bl_gwdo.o -module_cu_bmj.o: ../share/module_model_constants.o -module_shcu_camuwshcu_driver.o: module_cam_support.o \ - module_mp_cammgmp_driver.o \ - module_cam_physconst.o \ - module_cam_wv_saturation.o \ - module_shcu_camuwshcu.o +module_cam_upper_bc.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -module_shcu_camuwshcu.o: module_cam_support.o \ - module_cam_constituents.o \ - module_cam_error_function.o \ - module_cam_esinti.o \ - module_cam_physconst.o \ - module_bl_camuwpbl_driver.o -module_shcu_deng.o: +module_cam_constituents.o: \ + module_cam_shr_kind_mod.o \ + module_cam_physconst.o \ + module_cam_support.o \ + ../frame/module_wrf_error.o -module_cu_camzm_driver.o: ../share/module_model_constants.o \ - module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_mp_cammgmp_driver.o \ - module_bl_camuwpbl_driver.o \ - module_cu_camzm.o -module_cu_camzm.o: module_cam_shr_kind_mod.o \ - module_cam_constituents.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_wv_saturation.o \ - module_cam_cldwat.o +module_cam_trb_mtn_stress.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -module_cam_error_function.o: -module_cam_cldwat.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_wv_saturation.o \ - module_cam_physconst.o +module_cam_molec_diff.o: \ + module_cam_support.o \ + module_cam_constituents.o \ + module_cam_upper_bc.o -module_cam_esinti.o: module_cam_shr_kind_mod.o \ - module_cam_wv_saturation.o -module_cam_wv_saturation.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_gffgch.o +module_data_cam_mam_aero.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_mp_radconstants.o -module_cam_gffgch.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o -module_cam_physconst.o: module_cam_shr_kind_mod.o \ - module_cam_shr_const_mod.o +module_data_cam_mam_asect.o: \ + module_cam_shr_kind_mod.o \ + module_data_cam_mam_aero.o -module_cam_shr_const_mod.o: module_cam_shr_kind_mod.o -module_cam_support.o: module_cam_shr_kind_mod.o \ - ../frame/module_state_description.o +module_cam_bl_diffusion_solver.o: \ + module_cam_support.o -module_cam_shr_kind_mod.o: -module_cu_kf.o: ../frame/module_wrf_error.o +module_cam_bl_eddy_diff.o: \ + module_cam_bl_diffusion_solver.o \ + module_cam_support.o -module_cu_kfcup.o: ../frame/module_wrf_error.o \ - ../frame/module_state_description.o \ - $(CF2) \ - ../share/module_model_constants.o \ - module_mixactivate.o +module_bl_camuwpbl_driver.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_constituents.o \ + module_cam_bl_diffusion_solver.o \ + module_cam_physconst.o \ + module_cam_trb_mtn_stress.o \ + module_cam_bl_eddy_diff.o \ + module_cam_wv_saturation.o \ + module_cam_molec_diff.o \ + module_data_cam_mam_aero.o \ + ../share/module_model_constants.o \ + module_cam_esinti.o -module_cu_kfeta.o: ../frame/module_wrf_error.o -module_cu_gd.o: +module_sf_mynn.o: \ + module_bl_mynn.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o -module_cu_ksas.o: - -module_cu_nsas.o: -module_cu_du.o: ../frame/module_wrf_error.o +module_sf_fogdes.o: \ + ../share/module_model_constants.o -module_gfs_physcons.o: module_gfs_machine.o -module_gfs_funcphys.o: module_gfs_machine.o \ - module_gfs_physcons.o +module_bl_fogdes.o: \ + ../share/module_model_constants.o -module_cu_sas.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_scalesas.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_osas.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o +module_sf_gfdl.o: \ + module_gfs_machine.o \ + module_sf_exchcoef.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_cu_tiedtke.o:module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o -module_cu_ntiedtke.o: ../share/module_model_constants.o +module_cu_bmj.o: \ + ../share/module_model_constants.o -module_ra_gfdleta.o: ../frame/module_dm.o \ - module_mp_etanew.o -module_ra_rrtm.o: ../frame/module_wrf_error.o \ - module_ra_clWRF_support.o \ - ../frame/module_dm.o +module_shcu_camuwshcu_driver.o: \ + module_data_cam_mam_asect.o \ + module_cam_support.o \ + module_mp_cammgmp_driver.o \ + module_cam_physconst.o \ + module_cam_wv_saturation.o \ + module_shcu_camuwshcu.o -module_ra_cam_support.o: module_cam_support.o \ - ../frame/module_wrf_error.o -module_ra_cam.o: module_ra_cam_support.o \ - module_cam_support.o \ - module_ra_clWRF_support.o \ - ../frame/module_wrf_error.o +module_shcu_camuwshcu.o: \ + module_cam_support.o \ + module_cam_constituents.o \ + module_cam_error_function.o \ + module_cam_esinti.o \ + module_cam_physconst.o \ + module_bl_camuwpbl_driver.o -module_mp_lin.o : ../frame/module_wrf_error.o \ - module_mp_radar.o -module_ra_flg.o: ../frame/module_wrf_error.o \ - ../frame/module_dm.o +module_shcu_deng.o: \ + ../frame/module_wrf_error.o -module_mp_sbu_ylin.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o -module_mp_milbrandt2mom.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o +module_cu_camzm_driver.o: \ + module_data_cam_mam_asect.o \ + ../share/module_model_constants.o \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_mp_cammgmp_driver.o \ + module_bl_camuwpbl_driver.o \ + module_cu_camzm.o -module_mp_thompson.o : ../frame/module_wrf_error.o \ - module_mp_radar.o -module_mp_nssl_2mom.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o +module_cu_camzm.o: \ + module_cam_shr_kind_mod.o \ + module_cam_constituents.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_wv_saturation.o \ + module_cam_cldwat.o -module_mp_fast_sbm.o : module_mp_radar.o - -module_mp_full_sbm.o : module_mp_radar.o - -module_mp_cammgmp_driver.o : module_cam_mp_microp_aero.o \ - module_cam_constituents.o \ - module_cam_shr_kind_mod.o \ - module_cam_cldwat.o \ - module_cam_mp_cldwat2m_micro.o \ - module_cam_physconst.o \ - module_cam_support.o \ - module_data_cam_mam_aero.o \ - module_data_cam_mam_asect.o \ - module_cam_wv_saturation.o \ - module_cam_mp_ndrop.o \ - module_cam_mp_conv_water.o \ - ../frame/module_state_description.o -module_cam_mp_microp_aero.o : module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_error_function.o \ - module_cam_wv_saturation.o \ - module_cam_mp_ndrop.o \ - module_data_cam_mam_aero.o -module_cam_mp_cldwat2m_micro.o : module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_error_function.o \ - module_cam_wv_saturation.o +module_cam_error_function.o: \ -module_cam_mp_ndrop.o : module_cam_shr_kind_mod.o \ - module_data_cam_mam_aero.o \ - module_cam_support.o \ - module_cam_physconst.o \ - module_cam_constituents.o \ - module_cam_error_function.o \ - module_cam_wv_saturation.o -module_cam_mp_modal_aero_initialize_data_phys.o : module_data_cam_mam_aero.o -module_cam_mp_conv_water.o: module_cam_shr_kind_mod.o \ - module_cam_support.o \ - module_cam_physconst.o +module_cam_cldwat.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_wv_saturation.o \ + module_cam_physconst.o -module_cam_mp_qneg3.o: module_cam_shr_kind_mod.o \ - module_cam_support.o -module_cam_mp_radconstants.o : module_cam_shr_kind_mod.o \ - module_cam_support.o -module_cam_infnan.o: module_cam_shr_kind_mod.o +module_cam_esinti.o: \ + module_cam_shr_kind_mod.o \ + module_cam_wv_saturation.o -module_mp_gsfcgce.o : ../frame/module_wrf_error.o \ - module_mp_radar.o -module_sf_myjsfc.o: ../share/module_model_constants.o +module_cam_wv_saturation.o: \ + ../frame/module_wrf_error.o \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_gffgch.o -module_sf_qnsesfc.o: ../share/module_model_constants.o -module_sf_gfs.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o \ - module_progtm.o +module_cam_gffgch.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o -module_sf_noahdrv.o: module_sf_noahlsm.o \ - module_sf_noahlsm_glacial_only.o \ - module_data_gocart_dust.o \ - module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o -module_sf_noahlsm.o: ../share/module_model_constants.o +module_cam_physconst.o: \ + module_cam_shr_kind_mod.o \ + module_cam_shr_const_mod.o -module_sf_clm.o: module_cam_shr_kind_mod.o \ - module_cam_shr_const_mod.o \ - module_cam_support.o \ - module_sf_urban.o \ - module_sf_noahlsm.o \ - module_ra_gfdleta.o \ - ../share/module_date_time.o \ - ../frame/module_wrf_error.o \ - ../frame/module_configure.o -module_sf_ctsm.o: ../frame/module_dm.o \ - ../frame/module_configure.o \ - ../frame/module_wrf_error.o +module_cam_shr_const_mod.o: \ + module_cam_shr_kind_mod.o -module_sf_ssib.o: ../share/module_model_constants.o -module_sf_noah_seaice_drv.o: module_sf_noah_seaice.o +module_cam_support.o: \ + ../frame/module_wrf_error.o \ + module_cam_shr_kind_mod.o \ + ../frame/module_state_description.o -module_sf_noah_seaice.o: module_sf_noahlsm.o ../share/module_model_constants.o -module_sf_noahmpdrv.o: module_sf_noahmplsm.o \ - module_data_gocart_dust.o \ - module_sf_noahmp_glacier.o \ - module_sf_noahmp_groundwater.o \ - module_sf_gecros.o \ - ../share/module_model_constants.o \ - module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o +module_cam_shr_kind_mod.o: \ -module_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o -module_sf_noahmplsm.o: ../share/module_model_constants.o \ - module_sf_gecros.o \ - module_sf_myjsfc.o - -module_sf_noahmp_groundwater.o: module_sf_noahmplsm.o - -module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o module_bep_bem_helper.o - -module_sf_bep_bem.o: ../share/module_model_constants.o module_sf_bem.o module_sf_urban.o module_bep_bem_helper.o +module_cu_kf.o: \ + ../frame/module_wrf_error.o -module_sf_bem.o: ../share/module_model_constants.o -module_sf_ruclsm.o: ../frame/module_wrf_error.o module_data_gocart_dust.o +module_cu_kfcup.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + $(CF2) \ + ../share/module_model_constants.o \ + module_mixactivate.o -module_sf_pxlsm.o: ../share/module_model_constants.o module_sf_pxlsm_data.o -module_ra_rrtmg_sw.o: module_ra_rrtmg_aero_optical_util_cmaq.o module_ra_rrtmg_lw.o -module_ra_rrtmg_swf.o: module_ra_rrtmg_lwf.o -module_ra_rrtmg_swk.o: module_ra_rrtmg_lwk.o module_ra_effective_radius.o +module_cu_kfeta.o: \ + ../frame/module_wrf_error.o -module_ra_rrtmg_lw.o: ../share/module_model_constants.o \ - module_ra_clWRF_support.o -module_ra_rrtmg_lwf.o: ../share/module_model_constants.o \ - module_ra_clWRF_support.o -module_ra_rrtmg_lwk.o: ../share/module_model_constants.o +module_cu_gd.o: \ -module_physics_addtendc.o: \ - module_cu_kf.o \ - module_cu_kfeta.o \ - $(PHYS_CU) \ - ../frame/module_state_description.o \ - ../frame/module_configure.o - -module_physics_init.o : \ - module_ra_rrtm.o \ - module_ra_rrtmg_lwf.o \ - module_ra_rrtmg_swf.o \ - module_ra_rrtmg_lw.o \ - module_ra_rrtmg_sw.o \ - module_ra_rrtmg_lwk.o \ - module_ra_rrtmg_swk.o \ - module_ra_cam.o \ - $(PHYS_CU) $(PHYS_BL) \ - module_ra_cam_support.o \ - module_ra_clWRF_support.o \ - module_ra_sw.o \ - module_ra_gsfcsw.o \ - module_ra_gfdleta.o \ - module_ra_hs.o \ - module_ra_flg.o \ - module_sf_sfclay.o \ - module_sf_sfclayrev.o \ - module_sf_slab.o \ - module_sf_myjsfc.o \ - module_sf_mynn.o \ - module_sf_fogdes.o \ - module_sf_urban.o \ - module_sf_qnsesfc.o \ - module_sf_pxsfclay.o \ - module_sf_noahlsm.o \ - module_sf_noahdrv.o \ - module_sf_clm.o \ - module_sf_ctsm.o \ - module_sf_ssib.o \ - module_sf_noahmplsm.o \ - module_sf_noahmpdrv.o \ - module_sf_bep.o \ - module_sf_bep_bem.o \ - module_sf_ruclsm.o \ - module_sf_pxlsm.o \ - module_sf_lake.o \ - module_bl_ysu.o \ - module_bl_mrf.o \ - module_bl_gfs.o \ - module_bl_gfsedmf.o \ - module_bl_acm.o \ - module_bl_myjpbl.o \ - module_bl_qnsepbl.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ - module_bl_myjurb.o \ - module_bl_boulac.o \ - module_bl_camuwpbl_driver.o \ - module_bl_temf.o \ - module_bl_mfshconvpbl.o \ - module_cu_kf.o \ - module_cu_g3.o \ - module_cu_kfeta.o \ - module_cu_mskf.o \ - module_cu_bmj.o \ - module_cu_gd.o \ - module_cu_ksas.o \ - module_cu_nsas.o \ - module_cu_sas.o \ - module_cu_scalesas.o \ - module_cu_osas.o \ - module_cu_camzm_driver.o \ - module_cu_kfcup.o \ - module_shcu_camuwshcu.o \ - module_shcu_deng.o \ - module_shcu_grims.o \ - module_mp_sbu_ylin.o \ - module_mp_wsm3.o \ - module_mp_wsm5.o \ - module_mp_wsm6.o \ - module_mp_wsm6r.o \ - module_mp_etanew.o \ - module_mp_fer_hires.o \ - module_mp_fast_sbm.o \ - module_fdda_psufddagd.o \ - module_fdda_spnudging.o \ - module_fddaobs_rtfdda.o \ - module_mp_thompson.o \ - module_mp_gsfcgce.o \ - module_mp_gsfcgce_4ice_nuwrf.o \ - module_mp_morr_two_moment.o \ - module_mp_milbrandt2mom.o \ - module_mp_nssl_2mom.o \ - module_mp_wdm5.o \ - module_mp_wdm6.o \ - module_cam_physconst.o \ - module_cam_shr_kind_mod.o \ - module_mp_cammgmp_driver.o \ - module_cam_esinti.o \ - module_cam_constituents.o \ - module_cam_mp_modal_aero_initialize_data_phys.o \ - module_cam_support.o \ - module_wind_fitch.o \ - module_gocart_coupling.o \ - module_data_gocart_dust.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_wrf_error.o \ - ../frame/module_dm.o \ - ../share/module_llxy.o \ - ../share/module_model_constants.o -module_microphysics_driver.o: \ - module_mixactivate.o \ - module_mp_kessler.o module_mp_sbu_ylin.o module_mp_lin.o \ - $(PHYS_MP) \ - module_mp_wsm3.o module_mp_wsm5.o \ - module_mp_wsm6.o module_mp_etanew.o \ - module_mp_wsm6r.o \ - module_mp_fer_hires.o \ - module_mp_thompson.o \ - module_mp_gsfcgce.o \ - module_mp_gsfcgce_4ice_nuwrf.o \ - module_mp_morr_two_moment.o \ - module_mp_morr_two_moment_aero.o \ - module_mp_milbrandt2mom.o \ - module_mp_nssl_2mom.o \ - module_mp_wdm5.o module_mp_wdm6.o \ - module_mp_cammgmp_driver.o \ - module_irrigation.o \ - module_mp_fast_sbm.o \ - ../frame/module_driver_constants.o \ - ../frame/module_state_description.o \ - ../frame/module_wrf_error.o \ - ../frame/module_configure.o \ - ../frame/module_comm_dm.o \ - ../frame/module_dm.o \ - ../share/module_model_constants.o +module_cu_ksas.o: \ -module_shallowcu_driver.o: \ - module_shcu_camuwshcu_driver.o \ - module_shcu_deng.o \ - ../frame/module_state_description.o \ - ../share/module_model_constants.o -module_cu_gf_deep.o: \ - module_cu_gf_ctrans.o -module_cu_gf_wrfdrv.o: \ - module_cu_gf_deep.o \ - module_cu_gf_sh.o -module_cu_gf_sh.o: \ - module_cu_gf_deep.o -module_cu_gf_ctrans.o: \ - ../chem/module_chem_utilities.o \ - ../share/module_HLaw.o \ - ../share/module_ctrans_aqchem.o \ - ../frame/module_state_description.o -module_cumulus_driver.o: \ - module_cu_kf.o \ - module_cu_g3.o \ - module_cu_gf_wrfdrv.o \ - module_cu_kfeta.o \ - $(PHYS_CU) \ - module_cu_bmj.o \ - module_cu_gd.o \ - module_cu_ksas.o \ - module_cu_nsas.o \ - module_cu_sas.o \ - module_cu_scalesas.o \ - module_cu_osas.o \ - module_cu_camzm_driver.o \ - module_cu_tiedtke.o \ - module_cu_ntiedtke.o \ - module_cu_mskf.o \ - module_cu_kfcup.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_domain.o \ - ../frame/module_dm.o \ - ../frame/module_comm_dm.o \ - ../frame/module_wrf_error.o \ - ../share/module_model_constants.o +module_cu_nsas.o: \ -module_pbl_driver.o: \ - module_bl_myjpbl.o \ - module_bl_myjurb.o \ - module_bl_qnsepbl.o \ - module_bl_acm.o \ - module_bl_ysu.o \ - module_bl_mrf.o \ - module_bl_boulac.o \ - module_bl_camuwpbl_driver.o \ - module_bl_gfs.o \ - module_bl_gfsedmf.o \ - module_bl_mynn.o \ - module_bl_mynn_wrapper.o \ - module_bl_fogdes.o \ - module_bl_gwdo.o \ - module_bl_gwdo_gsl.o \ - module_bl_temf.o \ - module_bl_mfshconvpbl.o \ - $(PHYS_BL) \ - module_wind_fitch.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../share/module_model_constants.o - -module_data_gocart_dust.o: -module_mixactivate.o: \ - module_radiation_driver.o +module_cu_du.o: \ + ../frame/module_wrf_error.o -module_radiation_driver.o: \ - module_ra_sw.o \ - module_ra_gsfcsw.o \ - module_ra_rrtm.o \ - module_ra_rrtmg_lw.o \ - module_ra_rrtmg_sw.o \ - module_ra_rrtmg_aero_optical_util_cmaq.o \ - module_ra_rrtmg_lwf.o \ - module_ra_rrtmg_swf.o \ - module_ra_rrtmg_lwk.o \ - module_ra_rrtmg_swk.o \ - module_ra_cam.o \ - module_ra_farms.o \ - module_ra_gfdleta.o \ - module_ra_hs.o \ - module_ra_goddard.o \ - module_ra_flg.o \ - module_ra_eclipse.o \ - module_ra_aerosol.o \ - module_mp_thompson.o \ - ../frame/module_driver_constants.o \ - ../frame/module_state_description.o \ - ../frame/module_dm.o \ - ../frame/module_comm_dm.o \ - ../frame/module_domain.o \ - ../frame/module_wrf_error.o \ - ../frame/module_configure.o \ - ../share/module_bc.o \ - ../share/module_model_constants.o -module_surface_driver.o: \ - module_sf_sfclay.o \ - module_sf_sfclayrev.o \ - module_sf_slab.o \ - module_sf_myjsfc.o \ - module_sf_qnsesfc.o \ - module_sf_pxsfclay.o \ - module_sf_gfs.o \ - module_sf_noah_seaice_drv.o \ - module_sf_noahmp_groundwater.o \ - module_sf_noahdrv.o \ - module_sf_clm.o \ - module_sf_ctsm.o \ - module_sf_ssib.o \ - module_sf_noahmpdrv.o \ - module_sf_ruclsm.o \ - module_sf_pxlsm.o \ - module_sf_mynn.o \ - module_sf_fogdes.o \ - module_sf_sfcdiags.o \ - module_sf_sfcdiags_ruclsm.o \ - module_sf_sstskin.o \ - module_sf_lake.o \ - module_sf_tmnupdate.o \ - module_sf_temfsfclay.o \ - module_sf_idealscmsfclay.o \ - module_sf_scmflux.o \ - module_sf_scmskintemp.o \ - module_sf_ocean_driver.o \ - module_irrigation.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_cpl.o \ - ../share/module_model_constants.o - -module_sf_ocean_driver.o : \ - module_sf_oml.o \ - module_sf_3dpwp.o \ - ../frame/module_state_description.o +module_gfs_physcons.o: \ + module_gfs_machine.o -module_diagnostics_driver.o: \ - module_lightning_driver.o \ - module_diag_misc.o \ - module_diag_nwp.o \ - module_diag_cl.o \ - module_diag_cordex.o \ - module_diag_pld.o \ - module_diag_zld.o \ - module_diag_afwa.o \ - module_diag_hailcast.o \ - module_diag_rasm.o \ - module_diag_trad_fields.o \ - module_diag_solar.o \ - ../frame/module_comm_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_driver_constants.o \ - ../share/module_model_constants.o -module_diag_misc.o: \ - ../frame/module_dm.o +module_gfs_funcphys.o: \ + module_gfs_machine.o \ + module_gfs_physcons.o -module_diag_cl.o: \ - ../frame/module_dm.o \ - ../frame/module_configure.o -module_diagvar_cordex.o: \ - ../frame/module_wrf_error.o \ - ../share/module_model_constants.o +module_cu_sas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_cordex.o: \ - ../frame/module_dm.o \ - ../frame/module_configure.o \ - module_diagvar_cordex.o -module_diag_pld.o: \ - ../share/module_model_constants.o +module_cu_scalesas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_zld.o: \ - ../share/module_model_constants.o -module_diag_afwa.o: \ - module_diag_trad_fields.o \ - ../frame/module_domain.o \ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../frame/module_streams.o \ - ../external/esmf_time_f90/module_utility.o \ - ../share/module_model_constants.o +module_cu_osas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_hailcast.o: \ - ../frame/module_configure.o \ - ../frame/module_domain.o \ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_streams.o \ - ../external/esmf_time_f90/module_utility.o \ - ../share/module_model_constants.o -module_diag_rasm.o: \ - module_cam_shr_const_mod.o +module_cu_tiedtke.o: \ + ../share/module_model_constants.o \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_trad_fields.o: \ - module_diag_functions.o \ - ../share/module_model_constants.o -module_diag_solar.o: \ - ../share/module_model_constants.o +module_cu_ntiedtke.o: \ + ../share/module_model_constants.o \ + ccpp_kind_types.o \ + physics_mmm/cu_ntiedtke.o -module_diag_refl.o: \ - ../frame/module_dm.o \ - ../share/module_model_constants.o -module_mixactivate.o: \ - module_radiation_driver.o +module_ra_gfdleta.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + ../frame/module_dm.o \ + module_mp_etanew.o -module_fddagd_driver.o: \ - module_fdda_spnudging.o \ - module_fdda_psufddagd.o \ - ../frame/module_state_description.o \ - ../frame/module_configure.o \ - ../share/module_model_constants.o -module_fddaobs_driver.o: \ - ../frame/module_domain.o \ - ../share/module_bc.o \ - ../share/module_model_constants.o \ - module_fddaobs_rtfdda.o +module_ra_rrtm.o: \ + ../frame/module_wrf_error.o \ + module_ra_clWRF_support.o \ + ../frame/module_dm.o -module_sf_lake.o : \ - ../share/module_model_constants.o - -module_fr_fire_driver.o: \ - ../share/module_model_constants.o \ - ../frame/module_comm_dm.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o \ - module_fr_fire_phys.o \ - module_fr_fire_model.o \ - module_fr_fire_util.o \ - module_fr_fire_core.o \ - module_fr_fire_atm.o +module_ra_cam_support.o: \ + module_cam_support.o \ + ../frame/module_wrf_error.o -module_fr_fire_driver_wrf.o: \ - ../share/module_model_constants.o \ - ../frame/module_comm_dm.o \ - module_fr_fire_driver.o \ - module_fr_fire_atm.o \ - module_fr_fire_util.o -module_fr_fire_atm.o: \ - ../share/module_model_constants.o \ - module_fr_fire_util.o +module_ra_cam.o: \ + module_ra_cam_support.o \ + module_ra_clWRF_support.o \ + module_ra_cam_support.o \ + module_cam_support.o \ + module_ra_clWRF_support.o \ + ../frame/module_wrf_error.o -module_fr_fire_model.o: \ - module_fr_fire_core.o \ - module_fr_fire_phys.o \ - module_fr_fire_util.o -module_fr_fire_core.o: \ - module_fr_fire_util.o \ - module_fr_fire_phys.o +module_mp_lin.o: \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -module_fr_fire_phys.o: \ - ../share/module_model_constants.o \ - module_fr_fire_util.o -module_fire_debug_output.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../share/mediation_integrate.o +module_ra_flg.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_dm.o -module_firebrand_spotting_mpi.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o -module_firebrand_spotting.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_domain_type.o \ - ../external/esmf_time_f90/module_symbols_util.o \ - ../external/esmf_time_f90/module_utility.o \ - module_firebrand_spotting_mpi.o +module_mp_sbu_ylin.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_fdda_spnudging.o :\ - ../frame/module_dm.o \ - ../frame/module_state_description.o \ - ../frame/module_domain.o \ - ../frame/module_wrf_error.o -module_sf_bep.o :\ - module_sf_urban.o +module_mp_milbrandt2mom.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_mp_wsm5.o :\ - module_mp_wsm5_accel.F \ - module_mp_radar.o -module_mp_wdm5.o :\ - module_mp_radar.o +module_mp_thompson.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_timing.o \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -module_mp_wsm6.o :\ - module_mp_radar.o -module_mp_wdm6.o :\ - module_mp_radar.o +module_mp_nssl_2mom.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_mp_morr_two_moment.o :\ - module_mp_radar.o -module_mp_wsm3.o :\ - module_mp_wsm3_accel.F +module_mp_fast_sbm.o: \ + ../frame/module_domain.o \ + module_mp_SBM_polar_radar.o \ + module_mp_radar.o -module_mp_radar.o : -module_lightning_driver.o : \ - module_ltng_crmpr92.o module_ltng_cpmpr92z.o module_ltng_iccg.o +module_mp_full_sbm.o: \ + module_mp_radar.o -module_ltng_cpmpr92z.o : -module_ltng_crmpr92.o : +module_mp_cammgmp_driver.o: \ + ../frame/module_configure.o \ + module_cam_mp_microp_aero.o \ + module_cam_constituents.o \ + module_cam_shr_kind_mod.o \ + module_cam_cldwat.o \ + module_cam_mp_cldwat2m_micro.o \ + module_cam_physconst.o \ + module_cam_support.o \ + module_data_cam_mam_aero.o \ + module_data_cam_mam_asect.o \ + module_cam_wv_saturation.o \ + module_cam_mp_ndrop.o \ + module_cam_mp_conv_water.o \ + ../frame/module_state_description.o -module_ltng_iccg.o : -module_ra_aerosol.o :\ - ../frame/module_wrf_error.o +module_cam_mp_microp_aero.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_error_function.o \ + module_cam_wv_saturation.o \ + module_cam_mp_ndrop.o \ + module_data_cam_mam_aero.o -module_gocart_coupling.o: -module_ra_goddard.o : ../frame/module_wrf_error.o \ - module_gocart_coupling.o \ - module_checkerror.o +module_cam_mp_cldwat2m_micro.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_error_function.o \ + module_cam_wv_saturation.o -module_mp_gsfcgce_4ice_nuwrf.o : ../frame/module_wrf_error.o \ - module_gocart_coupling.o \ - module_checkerror.o \ - module_mp_radar.o -# End of DEPENDENCIES for phys +module_cam_mp_ndrop.o: \ + module_cam_shr_kind_mod.o \ + module_data_cam_mam_aero.o \ + module_cam_support.o \ + module_cam_physconst.o \ + module_cam_constituents.o \ + module_cam_error_function.o \ + module_cam_wv_saturation.o -# DEPENDENCIES for share +module_cam_mp_modal_aero_initialize_data_phys.o: \ + module_data_cam_mam_aero.o -module_trajectory.o: ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o \ - ../frame/module_comm_dm.o \ - ../frame/module_state_description.o \ - module_model_constants.o \ - module_date_time.o \ - module_llxy.o -solve_interface.o: solve_em.int ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_timing.o ../frame/module_driver_constants.o \ - ../frame/module_wrf_error.o \ - ../frame/module_state_description.o ../phys/module_checkerror.o \ - ../frame/module_wrf_error.o module_trajectory.o +module_cam_mp_conv_water.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.o -start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o ../share/module_llxy.o -module_date_time.o: ../frame/module_wrf_error.o ../frame/module_configure.o \ - module_model_constants.o +module_cam_mp_qneg3.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -module_bc.o: ../frame/module_configure.o ../frame/module_state_description.o \ - ../frame/module_wrf_error.o module_model_constants.o -module_bc_time_utilities.o: $(ESMF_MOD_DEPENDENCE) +module_cam_mp_radconstants.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -module_get_file_names.o: ../frame/module_dm.o -module_io_wrf.o: module_date_time.o \ - ../frame/module_wrf_error.o ../frame/module_streams.o \ - $(ESMF_MOD_DEPENDENCE) +module_cam_infnan.o: \ + module_cam_shr_kind_mod.o -module_io_domain.o: module_io_wrf.o module_date_time.o ../frame/module_io.o \ - ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_state_description.o -output_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_state_description.o \ - ../frame/module_configure.o module_io_wrf.o \ - $(ESMF_MOD_DEPENDENCE) +module_mp_gsfcgce.o: \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -wrf_fddaobs_in.o: \ - module_date_time.o \ - module_llxy.o - -wrf_timeseries.o: wrf_tsin.o \ - module_model_constants.o \ - module_llxy.o \ - module_model_constants.o \ - module_string_tools.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_dm.o - -track_driver.o: track_input.o \ - module_model_constants.o \ - module_llxy.o \ - module_date_time.o \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_state_description.o \ - ../frame/module_dm.o - -input_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_state_description.o \ - ../frame/module_configure.o module_io_wrf.o \ - $(ESMF_MOD_DEPENDENCE) - -wrf_ext_write_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_timing.o - -wrf_ext_read_field.o : ../frame/module_io.o ../frame/module_wrf_error.o \ - ../frame/module_domain.o ../frame/module_timing.o - -module_soil_pre.o: module_date_time.o ../frame/module_state_description.o - -module_check_a_mundo.o: ../frame/module_configure.o ../frame/module_wrf_error.o \ - ../frame/module_state_description.o \ - ../share/module_model_constants.o \ - ../phys/module_bep_bem_helper.o - -dfi.o : ../frame/module_wrf_error.o ../frame/module_configure.o \ - ../frame/module_state_description.o \ - ../frame/module_domain.o ../frame/module_timing.o \ - ../frame/module_machine.o ../frame/module_comm_dm.o \ - ../frame/module_dm.o ../frame/module_driver_constants.o \ - module_model_constants.o module_date_time.o module_io_domain.o \ - $(ESMF_MOD_DEPENDENCE) - -module_optional_input.o: module_io_wrf.o module_io_domain.o \ - ../frame/module_domain.o ../frame/module_configure.o - -mediation_wrfmain.o: ../frame/module_domain.o ../frame/module_configure.o ../frame/module_dm.o \ - ../frame/module_timing.o $(ESMF_MOD_DEPENDENCE) \ - module_bc_time_utilities.o module_io_domain.o - -init_modules.o: ../frame/module_configure.o ../frame/module_driver_constants.o \ - ../frame/module_domain.o ../frame/module_machine.o \ - ../frame/module_nesting.o ../frame/module_timing.o \ - ../frame/module_tiles.o ../frame/module_io.o \ - ../frame/module_io_quilt.o ../frame/module_dm.o \ - ../external/io_int/io_int.o \ - module_io_wrf.o module_bc.o module_model_constants.o \ - ../frame/module_wrf_error.o - -interp_fcn.o: ../frame/module_timing.o ../frame/module_state_description.o ../frame/module_configure.o \ - ../frame/module_wrf_error.o module_model_constants.o module_interp_nmm.o module_interp_store.o - -module_interp_nmm.o: module_model_constants.o module_interp_store.o - -mediation_feedback_domain.o: ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_intermediate_nmm.o - -mediation_force_domain.o: ../frame/module_domain.o ../frame/module_configure.o - -mediation_integrate.o: ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_timing.o \ - $(ESMF_MOD_DEPENDENCE) \ - module_date_time.o module_bc_time_utilities.o \ - module_compute_geop.o \ - $(PERTMOD) \ - module_io_domain.o - - -mediation_interp_domain.o: ../frame/module_domain.o ../frame/module_configure.o \ - ../frame/module_timing.o -mediation_nest_move.o: \ - ../frame/module_domain.o \ - ../frame/module_configure.o \ - ../frame/module_state_description.o \ - ../frame/module_driver_constants.o \ - module_io_domain.o - -#mediation_conv_emissions.o: ../frame/module_domain.o ../frame/module_configure.o \ -# ../external/esmf_time_f90/ESMF_Mod.o \ -# module_date_time.o module_bc_time_utilities.o \ -# module_io_domain.o - -set_timekeeping.o: ../frame/module_domain.o ../frame/module_configure.o \ - $(ESMF_MOD_DEPENDENCE) - -wrf_inputout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput1out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput2out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput3out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput4out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput5out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput6out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput7out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput8out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput9out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput10out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput11out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_histout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist1out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist2out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist3out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist4out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist5out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist6out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist7out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist8out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist9out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist10out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist11out.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_restartout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_bdyout.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_inputin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist1in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist2in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist3in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist4in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist5in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist6in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist7in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist8in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist9in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist10in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxhist11in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput1in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput2in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput3in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput4in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput5in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput6in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput7in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput8in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput9in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput10in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_auxinput11in.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_bdyin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_histin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_restartin.o : ../frame/module_domain.o \ - ../frame/module_configure.o ../frame/module_io.o module_io_wrf.o module_bc_time_utilities.o -wrf_tsin.o : ../frame/module_domain.o - -track_input.o : ../frame/module_domain.o - -module_random.o: bobrand.o +module_sf_myjsfc.o: \ + ../share/module_model_constants.o -# End of DEPENDENCIES for share +module_sf_qnsesfc.o: \ + ../share/module_model_constants.o -# DEPENDENCIES for main -convert_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../share/module_bc.o \ - ../share/module_io_domain.o \ - $(ESMF_MOD_DEPENDENCE) +module_sf_gfs.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o \ + module_progtm.o -ideal_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../share/module_io_domain.o \ - ../dyn_$(SOLVER)/$(CASE_MODULE) \ - $(ESMF_MOD_DEPENDENCE) -ndown_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ +module_sf_noahdrv.o: \ + module_ra_gfdleta.o \ + ../frame/module_wrf_error.o \ + module_sf_noahlsm.o \ + module_sf_noahlsm_glacial_only.o \ + module_data_gocart_dust.o \ + module_sf_urban.o \ + module_sf_bep.o \ + module_sf_bep_bem.o + + +module_sf_noahlsm.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_sf_clm.o: \ + module_cam_shr_kind_mod.o \ + module_cam_shr_const_mod.o \ + module_cam_support.o \ + module_sf_urban.o \ + module_sf_noahlsm.o \ + module_ra_gfdleta.o \ + ../share/module_date_time.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o + + +module_sf_ctsm.o: \ ../frame/module_dm.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o + + +module_sf_ssib.o: \ + ../share/module_model_constants.o + + +module_sf_noah_seaice_drv.o: \ ../frame/module_wrf_error.o \ - ../frame/module_integrate.o \ - ../share/module_bc.o \ - ../share/module_io_domain.o \ - ../share/module_get_file_names.o \ + module_sf_noah_seaice.o + + +module_sf_noah_seaice.o: \ ../share/module_model_constants.o \ - ../share/module_soil_pre.o \ - ../dyn_em/module_initialize_$(IDEAL_CASE).o \ - ../dyn_em/module_big_step_utilities_em.o \ - ../dyn_em/nest_init_utils.o \ - $(ESMF_MOD_DEPENDENCE) + module_sf_noahlsm.o \ + module_sf_noahlsm.o \ + ../share/module_model_constants.o -# this already built above :../dyn_em/module_initialize.real.o \ -real_em.o: \ - ../frame/module_machine.o \ + +module_sf_noahmpdrv.o: \ + ../frame/module_comm_dm.o \ ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../dyn_em/module_initialize_$(IDEAL_CASE).o \ - ../dyn_em/module_big_step_utilities_em.o \ - ../share/module_io_domain.o \ - ../share/module_date_time.o \ - ../share/module_optional_input.o \ - ../share/module_bc_time_utilities.o \ - ../dyn_em/module_wps_io_arw.o \ - $(ESMF_MOD_DEPENDENCE) -# ../chem/module_input_chem_data.o \ -# ../chem/module_input_chem_bioemiss.o \ + module_ra_gfdleta.o \ + module_sf_noahmplsm.o \ + module_data_gocart_dust.o \ + module_sf_noahmp_glacier.o \ + module_sf_noahmp_groundwater.o \ + module_sf_gecros.o \ + ../share/module_model_constants.o \ + module_sf_urban.o \ + module_sf_bep.o \ + module_sf_bep_bem.o -tc_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../dyn_em/module_initialize_$(IDEAL_CASE).o \ - ../dyn_em/module_big_step_utilities_em.o \ - ../share/module_io_domain.o \ - ../share/module_date_time.o \ - ../share/module_optional_input.o \ - ../share/module_bc_time_utilities.o \ - $(ESMF_MOD_DEPENDENCE) +module_sf_noahlsm_glacial_only.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_sf_noahlsm.o \ + module_sf_noahmplsm.o + + +module_sf_noahmplsm.o: \ + ../share/module_model_constants.o \ + module_sf_gecros.o \ + module_sf_myjsfc.o + + +module_sf_noahmp_groundwater.o: \ + module_sf_noahmplsm.o + + +module_sf_bep.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_sf_urban.o \ + module_bep_bem_helper.o + + +module_sf_bep_bem.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_sf_bem.o \ + module_sf_urban.o \ + module_bep_bem_helper.o + + +module_sf_bem.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o +module_sf_ruclsm.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_data_gocart_dust.o + + +module_sf_pxlsm.o: \ + ../share/module_model_constants.o \ + module_sf_pxlsm_data.o -wrf.o: ../main/module_wrf_top.o -wrf_ESMFMod.o: ../main/module_wrf_top.o +module_sf_sfclayrev.o: \ + ccpp_kind_types.o \ + physics_mmm/sf_sfclayrev.o -wrf_SST_ESMF.o: wrf_ESMFMod.o -module_wrf_top.o: ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_integrate.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_wrf_error.o \ - ../frame/module_state_description.o \ - ../frame/module_cpl.o \ - $(ESMF_MOD_DEPENDENCE) +module_ra_rrtmg_sw.o: \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o \ + ../frame/module_wrf_error.o \ + module_ra_rrtmg_aero_optical_util_cmaq.o \ + module_ra_rrtmg_lw.o -# End of DEPENDENCIES for main +module_ra_rrtmg_swf.o: \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o \ + ../frame/module_wrf_error.o \ + module_ra_rrtmg_lwf.o + + +module_ra_rrtmg_swk.o: \ + ../share/module_model_constants.o \ + module_ra_rrtmg_lwk.o \ + module_ra_effective_radius.o + + +module_ra_rrtmg_lw.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o + + +module_ra_rrtmg_lwf.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o \ + module_ra_clWRF_support.o + + +module_ra_rrtmg_lwk.o: \ + ../share/module_model_constants.o + + +module_physics_addtendc.o: \ + module_cu_kf.o \ + module_cu_kfeta.o \ + $(PHYS_CU) \ + ../frame/module_state_description.o \ + ../frame/module_configure.o + + +module_physics_init.o: \ + module_bl_gbmpbl.o \ + module_bl_shinhong.o \ + module_cu_ntiedtke.o \ + module_cu_tiedtke.o \ + ../frame/module_domain.o \ + module_mp_full_sbm.o \ + module_mp_jensen_ishmael.o \ + module_mp_morr_two_moment_aero.o \ + module_mp_ntu.o \ + module_mp_wdm7.o \ + module_mp_wsm7.o \ + module_ra_goddard.o \ + module_sf_gfdl.o \ + module_sf_oml.o \ + module_sf_temfsfclay.o \ + module_shcu_nscv.o \ + module_ra_rrtm.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ + module_ra_rrtmg_lw.o \ + module_ra_rrtmg_sw.o \ + module_ra_rrtmg_lwk.o \ + module_ra_rrtmg_swk.o \ + module_ra_cam.o \ + $(PHYS_CU) \ + $(PHYS_BL) \ + module_ra_cam_support.o \ + module_ra_clWRF_support.o \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_gfdleta.o \ + module_ra_hs.o \ + module_ra_flg.o \ + module_sf_sfclay.o \ + physics_mmm/sf_sfclayrev.o \ + module_sf_slab.o \ + module_sf_myjsfc.o \ + module_sf_mynn.o \ + module_sf_fogdes.o \ + module_sf_urban.o \ + module_sf_qnsesfc.o \ + module_sf_pxsfclay.o \ + module_sf_noahlsm.o \ + module_sf_noahdrv.o \ + module_sf_clm.o \ + module_sf_ctsm.o \ + module_sf_ssib.o \ + module_sf_noahmplsm.o \ + module_sf_noahmpdrv.o \ + module_sf_bep.o \ + module_sf_bep_bem.o \ + module_sf_ruclsm.o \ + module_sf_pxlsm.o \ + module_sf_lake.o \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_gfs.o \ + module_bl_gfsedmf.o \ + module_bl_acm.o \ + module_bl_myjpbl.o \ + module_bl_qnsepbl.o \ + module_bl_mynn.o \ + module_bl_mynn_wrapper.o \ + module_bl_myjurb.o \ + module_bl_boulac.o \ + module_bl_camuwpbl_driver.o \ + module_bl_temf.o \ + module_bl_mfshconvpbl.o \ + module_cu_kf.o \ + module_cu_g3.o \ + module_cu_kfeta.o \ + module_cu_mskf.o \ + module_cu_bmj.o \ + module_cu_gd.o \ + module_cu_ksas.o \ + module_cu_nsas.o \ + module_cu_sas.o \ + module_cu_scalesas.o \ + module_cu_osas.o \ + module_cu_camzm_driver.o \ + module_cu_kfcup.o \ + module_shcu_camuwshcu.o \ + module_shcu_deng.o \ + module_shcu_grims.o \ + module_mp_sbu_ylin.o \ + module_mp_wsm3.o \ + module_mp_wsm5.o \ + physics_mmm/mp_wsm6.o \ + module_mp_wsm6r.o \ + module_mp_etanew.o \ + module_mp_fer_hires.o \ + module_mp_fast_sbm.o \ + module_fdda_psufddagd.o \ + module_fdda_spnudging.o \ + module_fddaobs_rtfdda.o \ + module_mp_thompson.o \ + module_mp_gsfcgce.o \ + module_mp_gsfcgce_4ice_nuwrf.o \ + module_mp_morr_two_moment.o \ + module_mp_milbrandt2mom.o \ + module_mp_nssl_2mom.o \ + module_mp_wdm5.o \ + module_mp_wdm6.o \ + module_cam_physconst.o \ + module_cam_shr_kind_mod.o \ + module_mp_cammgmp_driver.o \ + module_cam_esinti.o \ + module_cam_constituents.o \ + module_cam_mp_modal_aero_initialize_data_phys.o \ + module_cam_support.o \ + module_wind_fitch.o \ + module_wind_mav.o \ + module_gocart_coupling.o \ + module_data_gocart_dust.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + ../frame/module_dm.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o + + +module_microphysics_driver.o: \ + ../frame/module_domain.o \ + module_fire_emis.o \ + module_mp_full_sbm.o \ + module_mp_jensen_ishmael.o \ + module_mp_ntu.o \ + module_mp_wdm7.o \ + module_mp_wsm7.o \ + module_mixactivate.o \ + module_mp_kessler.o \ + module_mp_sbu_ylin.o \ + module_mp_lin.o \ + $(PHYS_MP) \ + module_mp_wsm3.o \ + module_mp_wsm5.o \ + module_mp_wsm6.o \ + module_mp_etanew.o \ + module_mp_wsm6r.o \ + module_mp_fer_hires.o \ + module_mp_thompson.o \ + module_mp_gsfcgce.o \ + module_mp_gsfcgce_4ice_nuwrf.o \ + module_mp_morr_two_moment.o \ + module_mp_morr_two_moment_aero.o \ + module_mp_milbrandt2mom.o \ + module_mp_nssl_2mom.o \ + module_mp_wdm5.o \ + module_mp_wdm6.o \ + module_mp_cammgmp_driver.o \ + module_irrigation.o \ + module_mp_fast_sbm.o \ + ../frame/module_driver_constants.o \ + ../frame/module_state_description.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../frame/module_comm_dm.o \ + ../frame/module_dm.o \ + ../share/module_model_constants.o + + +module_shallowcu_driver.o: \ + ../frame/module_domain.o \ + module_shcu_grims.o \ + module_shcu_nscv.o \ + module_shcu_camuwshcu_driver.o \ + module_shcu_deng.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o + + +module_cu_gf_deep.o: \ + module_cu_gf_ctrans.o + + +module_cu_gf_wrfdrv.o: \ + module_cu_gf_ctrans.o \ + module_gfs_physcons.o \ + module_cu_gf_deep.o \ + module_cu_gf_sh.o + + +module_cu_gf_sh.o: \ + module_cu_gf_ctrans.o \ + module_cu_gf_deep.o + + +module_cu_gf_ctrans.o: \ + ../chem/module_chem_utilities.o \ + ../share/module_HLaw.o \ + ../share/module_ctrans_aqchem.o \ + ../frame/module_state_description.o + + +module_cumulus_driver.o: \ + ../share/module_chem_share.o \ + module_cu_kf.o \ + module_cu_g3.o \ + module_cu_gf_wrfdrv.o \ + module_cu_kfeta.o \ + $(PHYS_CU) \ + module_cu_bmj.o \ + module_cu_gd.o \ + module_cu_ksas.o \ + module_cu_nsas.o \ + module_cu_sas.o \ + module_cu_scalesas.o \ + module_cu_osas.o \ + module_cu_camzm_driver.o \ + module_cu_tiedtke.o \ + module_cu_ntiedtke.o \ + module_cu_mskf.o \ + module_cu_kfcup.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_pbl_driver.o: \ + module_bl_gbmpbl.o \ + module_bl_keps.o \ + module_bl_shinhong.o \ + module_bl_myjpbl.o \ + module_bl_myjurb.o \ + module_bl_qnsepbl.o \ + module_bl_acm.o \ + module_bl_ysu.o \ + module_bl_mrf.o \ + module_bl_boulac.o \ + module_bl_camuwpbl_driver.o \ + module_bl_gfs.o \ + module_bl_gfsedmf.o \ + module_bl_mynn.o \ + module_bl_mynn_wrapper.o \ + module_bl_fogdes.o \ + module_bl_gwdo.o \ + module_bl_gwdo_gsl.o \ + module_bl_temf.o \ + module_bl_mfshconvpbl.o \ + module_ra_gfdleta.o \ + $(PHYS_BL) \ + module_wind_fitch.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_data_gocart_dust.o: \ + + +module_mixactivate.o: \ + ../share/module_model_constants.o \ + module_radiation_driver.o + + +module_radiation_driver.o: \ + module_ra_sw.o \ + module_ra_gsfcsw.o \ + module_ra_rrtm.o \ + module_ra_rrtmg_lw.o \ + module_ra_rrtmg_sw.o \ + module_ra_rrtmg_aero_optical_util_cmaq.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ + module_ra_rrtmg_lwk.o \ + module_ra_rrtmg_swk.o \ + module_ra_cam.o \ + module_ra_farms.o \ + module_ra_gfdleta.o \ + module_ra_hs.o \ + module_ra_goddard.o \ + module_ra_flg.o \ + module_ra_eclipse.o \ + module_ra_aerosol.o \ + module_mp_thompson.o \ + ../frame/module_driver_constants.o \ + ../frame/module_state_description.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../share/module_bc.o \ + ../share/module_model_constants.o + + +module_surface_driver.o: \ + module_ra_gfdleta.o \ + module_sf_noahlsm.o \ + module_sf_sfclay.o \ + module_sf_sfclayrev.o \ + module_sf_slab.o \ + module_sf_myjsfc.o \ + module_sf_qnsesfc.o \ + module_sf_pxsfclay.o \ + module_sf_gfs.o \ + module_sf_noah_seaice_drv.o \ + module_sf_noahmp_groundwater.o \ + module_sf_noahdrv.o \ + module_sf_clm.o \ + module_sf_ctsm.o \ + module_sf_ssib.o \ + module_sf_noahmpdrv.o \ + module_sf_ruclsm.o \ + module_sf_pxlsm.o \ + module_sf_mynn.o \ + module_sf_fogdes.o \ + module_sf_sfcdiags.o \ + module_sf_sfcdiags_ruclsm.o \ + module_sf_sstskin.o \ + module_sf_lake.o \ + module_sf_tmnupdate.o \ + module_sf_temfsfclay.o \ + module_sf_idealscmsfclay.o \ + module_sf_scmflux.o \ + module_sf_scmskintemp.o \ + module_sf_ocean_driver.o \ + module_irrigation.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_cpl.o \ + ../share/module_model_constants.o + + +module_sf_ocean_driver.o: \ + module_sf_oml.o \ + module_sf_3dpwp.o \ + ../frame/module_state_description.o + + +module_diagnostics_driver.o: \ + ../frame/module_streams.o \ + module_lightning_driver.o \ + module_diag_misc.o \ + module_diag_nwp.o \ + module_diag_cl.o \ + module_diag_cordex.o \ + module_diag_pld.o \ + module_diag_zld.o \ + module_diag_afwa.o \ + module_diag_hailcast.o \ + module_diag_rasm.o \ + module_diag_trad_fields.o \ + module_diag_solar.o \ + ../frame/module_comm_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../share/module_model_constants.o + + +module_diag_misc.o: \ + ../frame/module_dm.o + + +module_diag_cl.o: \ + ../frame/module_dm.o \ + ../frame/module_configure.o + +module_diagvar_cordex.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + +module_diag_cordex.o: \ + ../frame/module_dm.o \ + ../frame/module_configure.o \ + module_diagvar_cordex.o + +module_diag_pld.o: \ + ../share/module_model_constants.o + + +module_diag_zld.o: \ + ../share/module_model_constants.o + + +module_diag_afwa.o: \ + module_diag_trad_fields.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_streams.o \ + ../external/esmf_time_f90/module_utility.o \ + ../share/module_model_constants.o + + +module_diag_hailcast.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_streams.o \ + ../external/esmf_time_f90/module_utility.o \ + ../share/module_model_constants.o + + +module_diag_rasm.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_streams.o \ + module_cam_shr_const_mod.o + + +module_diag_trad_fields.o: \ + module_diag_functions.o \ + ../share/module_model_constants.o + + +module_diag_solar.o: \ + ../share/module_model_constants.o + + +module_diag_refl.o: \ + ../frame/module_dm.o \ + ../share/module_model_constants.o + + +module_mixactivate.o: \ + module_radiation_driver.o + + +module_fddagd_driver.o: \ + ../frame/module_domain.o \ + module_fdda_spnudging.o \ + module_fdda_psufddagd.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_fddaobs_driver.o: \ + ../frame/module_domain.o \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + module_fddaobs_rtfdda.o + + +module_sf_lake.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + + +module_fr_fire_driver.o: \ + ../share/module_model_constants.o \ + ../frame/module_comm_dm.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + module_fr_fire_phys.o \ + module_fr_fire_model.o \ + module_fr_fire_util.o \ + module_fr_fire_core.o \ + module_fr_fire_atm.o + + +module_fr_fire_driver_wrf.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_comm_dm.o \ + module_fr_fire_driver.o \ + module_fr_fire_atm.o \ + module_fr_fire_util.o + + +module_fr_fire_atm.o: \ + ../share/module_model_constants.o \ + module_fr_fire_util.o + + +module_fr_fire_model.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_fr_fire_core.o \ + module_fr_fire_phys.o \ + module_fr_fire_util.o + + +module_fr_fire_core.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_fr_fire_util.o \ + module_fr_fire_phys.o + + +module_fr_fire_phys.o: \ + ../share/module_model_constants.o \ + module_fr_fire_util.o + + +module_fire_debug_output.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../share/mediation_integrate.o + + +module_firebrand_spotting_mpi.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o + + +module_firebrand_spotting.o: \ + ../frame/module_domain_type.o \ + module_firebrand_spotting_mpi.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain_type.o \ + ../external/esmf_time_f90/module_symbols_util.o \ + ../external/esmf_time_f90/module_utility.o \ + module_firebrand_spotting_mpi.o + + +module_fdda_spnudging.o: \ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o + + +module_mp_wsm5.o: \ + ../share/module_model_constants.o \ + module_mp_wsm5_accel.F \ + module_mp_radar.o + + +module_mp_wdm5.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wsm6.o: \ + ccpp_kind_types.o \ + physics_mmm/mp_wsm6_effectRad.o \ + physics_mmm/mp_radar.o \ + physics_mmm/mp_wsm6.o + +module_mp_wdm6.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_morr_two_moment.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wsm3.o: \ + ../share/module_model_constants.o \ + module_mp_wsm3_accel.F + + +module_mp_radar.o: \ + ../frame/module_wrf_error.o + + +module_lightning_driver.o: \ + module_ltng_lpi.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o \ + module_ltng_crmpr92.o \ + module_ltng_cpmpr92z.o \ + module_ltng_iccg.o + + +module_ltng_cpmpr92z.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_ltng_crmpr92.o: \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_ltng_iccg.o: \ + + +module_ra_aerosol.o: \ + ../frame/module_wrf_error.o + + +module_gocart_coupling.o: \ + + +module_ra_goddard.o: \ + ../frame/module_wrf_error.o \ + module_gocart_coupling.o \ + module_checkerror.o + + +module_mp_gsfcgce_4ice_nuwrf.o: \ + ../frame/module_wrf_error.o \ + module_gocart_coupling.o \ + module_checkerror.o \ + module_mp_radar.o \ + + +physics_mmm/sf_sfclayrev.o: \ + ccpp_kind_types.o + + +physics_mmm/cu_ntiedtke.o: \ + ccpp_kind_types.o + + +physics_mmm/mp_wsm6.o: \ + ccpp_kind_types.o \ + physics_mmm/mp_radar.o \ + physics_mmm/module_libmassv.o + + +physics_mmm/mp_wsm6_effectRad.o: \ + ccpp_kind_types.o \ + physics_mmm/mp_wsm6.o + + +physics_mmm/bl_ysu.o: \ + ccpp_kind_types.o + + +physics_mmm/bl_gwdo.o : \ + ccpp_kind_types.o + + +# End of DEPENDENCIES for phys + + +# DEPENDENCIES for share + +module_trajectory.o: \ + ../frame/module_domain_type.o \ + ../frame/module_driver_constants.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_state_description.o \ + module_model_constants.o \ + module_date_time.o \ + module_llxy.o + + +solve_interface.o: \ + solve_em.int \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_driver_constants.o \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + ../phys/module_checkerror.o \ + ../frame/module_wrf_error.o \ + module_trajectory.o + + +start_domain.o: \ + start_domain_em.int \ + wrf_timeseries.o \ + track_driver.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../share/module_llxy.o + + +module_date_time.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + module_model_constants.o + + +module_bc.o: \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_wrf_error.o \ + module_model_constants.o + + +module_bc_time_utilities.o: \ + $(ESMF_MOD_DEPENDENCE) + + +module_get_file_names.o: \ + ../frame/module_dm.o + + +module_io_wrf.o: \ + module_date_time.o \ + ../frame/module_wrf_error.o \ + ../frame/module_streams.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_io_domain.o: \ + module_io_wrf.o \ + module_date_time.o \ + ../frame/module_io.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o + + +output_wrf.o: \ + ../frame/module_domain_type.o \ + module_model_constants.o \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + module_io_wrf.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf_fddaobs_in.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_model_constants.o \ + module_date_time.o \ + module_llxy.o + + +wrf_timeseries.o: \ + wrf_tsin.o \ + module_model_constants.o \ + module_llxy.o \ + module_model_constants.o \ + module_string_tools.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o + + +track_driver.o: \ + track_input.o \ + module_model_constants.o \ + module_llxy.o \ + module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_dm.o + + +input_wrf.o: \ + module_bc_time_utilities.o \ + module_date_time.o \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + module_io_wrf.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf_ext_write_field.o: \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_timing.o + + +wrf_ext_read_field.o: \ + ../frame/module_io.o \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_timing.o + + +module_soil_pre.o: \ + module_date_time.o \ + ../frame/module_state_description.o + + +module_check_a_mundo.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + ../share/module_model_constants.o \ + ../phys/module_bep_bem_helper.o + + +dfi.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_timing.o \ + ../frame/module_machine.o \ + ../frame/module_comm_dm.o \ + ../frame/module_dm.o \ + ../frame/module_driver_constants.o \ + module_model_constants.o \ + module_date_time.o \ + module_io_domain.o \ + $(ESMF_MOD_DEPENDENCE) + + +module_optional_input.o: \ + module_io_wrf.o \ + module_io_domain.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o + + +mediation_wrfmain.o: \ + ../frame/module_io.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_dm.o \ + ../frame/module_timing.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_bc_time_utilities.o \ + module_io_domain.o + + +init_modules.o: \ + ../frame/module_cpl.o \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../frame/module_domain.o \ + ../frame/module_machine.o \ + ../frame/module_nesting.o \ + ../frame/module_timing.o \ + ../frame/module_tiles.o \ + ../frame/module_io.o \ + ../frame/module_io_quilt.o \ + ../frame/module_dm.o \ + ../external/io_int/io_int.o \ + module_io_wrf.o \ + module_bc.o \ + module_model_constants.o \ + ../frame/module_wrf_error.o + + +interp_fcn.o: \ + ../frame/module_timing.o \ + ../frame/module_state_description.o \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o \ + module_model_constants.o \ + module_interp_nmm.o \ + module_interp_store.o + + +module_interp_nmm.o: \ + module_model_constants.o \ + module_interp_store.o + + +mediation_feedback_domain.o: \ + ../frame/module_timing.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_intermediate_nmm.o + + +mediation_force_domain.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o + + +mediation_integrate.o: \ + module_bc.o \ + ../dyn_em/module_bc_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_streams.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + $(ESMF_MOD_DEPENDENCE) \ + module_date_time.o \ + module_bc_time_utilities.o \ + module_compute_geop.o \ + $(PERTMOD) \ + module_io_domain.o + + +mediation_interp_domain.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o + + +mediation_nest_move.o: \ + module_compute_geop.o \ + ../frame/module_streams.o \ + ../frame/module_timing.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_driver_constants.o \ + module_io_domain.o + + +#mediation_conv_emissions.o: \ +# ../frame/module_domain.o \ +# ../frame/module_configure.o \ +# ../external/esmf_time_f90/ESMF_Mod.o \ +# module_date_time.o \ +# module_bc_time_utilities.o \ +# module_io_domain.o + + +set_timekeeping.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf_inputout.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput1out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput2out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput3out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput4out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput5out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput6out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput7out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput8out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput9out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput10out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput11out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_histout.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist1out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist2out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist3out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist4out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist5out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist6out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist7out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist8out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist9out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist10out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist11out.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_restartout.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_bdyout.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_inputin.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist1in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist2in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist3in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist4in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist5in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist6in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist7in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist8in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist9in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist10in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxhist11in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput1in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput2in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput3in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput4in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput5in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput6in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput7in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput8in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput9in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput10in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_auxinput11in.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_bdyin.o: \ + module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_histin.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_restartin.o: \ + module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_io.o \ + module_io_wrf.o \ + module_bc_time_utilities.o + + +wrf_tsin.o: \ + ../frame/module_domain.o + + +track_input.o: \ + ../frame/module_domain.o + + +module_random.o: \ + bobrand.o \ + +# End of DEPENDENCIES for share + +# DEPENDENCIES for main + +convert_em.o: \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + $(ESMF_MOD_DEPENDENCE) + + +ideal_em.o: \ + ../share/module_check_a_mundo.o \ + ../dyn_em/module_initialize_ideal.o \ + ../frame/module_wrf_error.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../dyn_$(SOLVER)/$(CASE_MODULE) \ + $(ESMF_MOD_DEPENDENCE) + + +ndown_em.o: \ + ../share/module_check_a_mundo.o \ + ../frame/module_domain_type.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_optional_input.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../frame/module_wrf_error.o \ + ../frame/module_integrate.o \ + ../share/module_bc.o \ + ../share/module_io_domain.o \ + ../share/module_get_file_names.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../dyn_em/module_initialize_$(IDEAL_CASE).o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../dyn_em/nest_init_utils.o \ + $(ESMF_MOD_DEPENDENCE) \ + + +# this already built above :../dyn_em/module_initialize.real.o \ +real_em.o: \ + ../share/module_bc.o \ + ../share/module_bc_time_utilities.o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_check_a_mundo.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_io_domain.o \ + ../frame/module_machine.o \ + ../share/module_optional_input.o \ + ../frame/module_timing.o \ + ../dyn_em/module_wps_io_arw.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../dyn_em/module_initialize_$(IDEAL_CASE).o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_io_domain.o \ + ../share/module_date_time.o \ + ../share/module_optional_input.o \ + ../share/module_bc_time_utilities.o \ + ../dyn_em/module_wps_io_arw.o \ + $(ESMF_MOD_DEPENDENCE) \ +# ../chem/module_input_chem_data.o \ +# ../chem/module_input_chem_bioemiss.o + + +tc_em.o: \ + ../share/module_bc.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_llxy.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../dyn_em/module_initialize_$(IDEAL_CASE).o \ + ../dyn_em/module_big_step_utilities_em.o \ + ../share/module_io_domain.o \ + ../share/module_date_time.o \ + ../share/module_optional_input.o \ + ../share/module_bc_time_utilities.o \ + $(ESMF_MOD_DEPENDENCE) + + +wrf.o: \ + ../main/module_wrf_top.o + + +wrf_ESMFMod.o: \ + ../share/module_bc_time_utilities.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../share/module_io_domain.o \ + ../frame/module_streams.o \ + ../main/module_wrf_top.o + + +wrf_SST_ESMF.o: \ + ../frame/module_io.o \ + wrf_ESMFMod.o + + +module_wrf_top.o: \ + ../share/module_check_a_mundo.o \ + ../share/module_date_time.o \ + ../share/module_io_domain.o \ + ../frame/module_nesting.o \ + ../frame/module_machine.o \ + ../frame/module_domain.o \ + ../frame/module_integrate.o \ + ../frame/module_driver_constants.o \ + ../frame/module_configure.o \ + ../frame/module_timing.o \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + ../frame/module_cpl.o \ + $(ESMF_MOD_DEPENDENCE) \ + +# End of DEPENDENCIES for main + +ideal_nmm.o: \ + ../share/module_bc.o \ + ../share/module_bc_time_utilities.o \ + ../share/module_check_a_mundo.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../dyn_em/module_initialize_ideal.o \ + ../share/module_io_domain.o \ + ../frame/module_machine.o \ + ../share/module_optional_input.o \ + ../frame/module_timing.o + + +real_nmm.o: \ + ../share/module_bc.o \ + ../share/module_bc_time_utilities.o \ + ../share/module_check_a_mundo.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../dyn_em/module_initialize_real.o \ + ../share/module_io_domain.o \ + ../frame/module_machine.o \ + ../share/module_optional_input.o \ + ../frame/module_timing.o + + +module_dm_stubs.o: \ + module_driver_constants.o + + +module_io_quilt_old.o: \ + module_configure.o \ + module_cpl.o \ + module_driver_constants.o \ + module_internal_header_util.o \ + module_quilt_outbuf_ops.o \ + module_timing.o \ + module_wrf_error.o + + +module_bl_eepsilon.o: \ + ../share/module_model_constants.o + + +module_bl_mfshconvpbl.o: \ + ../share/module_model_constants.o + + +module_bl_mynn_common.o: \ + module_gfs_machine.o \ + ../share/module_model_constants.o \ + ccpp_kind_types.o + + +module_cu_mskf.o: \ + ../frame/module_wrf_error.o + + +module_diag_nwp.o: \ + module_mp_thompson.o + + +module_dust_emis.o: \ + module_data_gocart_dust.o + + +module_fddaobs_rtfdda.o: \ + ../frame/module_domain.o \ + ../share/module_model_constants.o + + +module_fdda_psufddagd.o: \ + ../share/module_model_constants.o + + +module_fr_fire_util.o: \ + ../frame/module_wrf_error.o + + +module_gocart_seasalt.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_microphysics_zero_out.o: \ + ../frame/module_configure.o \ + ../frame/module_wrf_error.o + + +module_mp_jensen_ishmael.o: \ + ../frame/module_wrf_error.o + + +module_mp_morr_two_moment_aero.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wdm7.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_mp_wsm7.o: \ + ../share/module_model_constants.o \ + module_mp_radar.o + + +module_ra_clWRF_support.o: \ + ../frame/module_wrf_error.o + + +module_ra_effective_radius.o: \ + ../share/module_model_constants.o + + +module_ra_farms.o: \ + ../share/module_model_constants.o + + +module_ra_rrtmg_aero_optical_util_cmaq.o: \ + complex_number_module.o + + +module_sf_sstskin.o: \ + ../frame/module_wrf_error.o + + +module_sf_urban.o: \ + ../frame/module_wrf_error.o + + +module_wind_fitch.o: \ + ../frame/module_configure.o \ + ../frame/module_driver_constants.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o + + +module_interp_store.o: \ + ../frame/module_domain_type.o + + +module_llxy.o: \ + ../frame/module_wrf_error.o + + +wrf_tsin.o: \ + ../frame/module_configure.o \ + module_string_tools.o + + +adapt_timestep_em.o: \ + module_bc_em.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o + + +couple_or_uncouple_em.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_machine.o \ + ../frame/module_tiles.o + + +interp_domain_em.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o + + +module_advect_em.o: \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_after_all_rk_steps.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../phys/module_diagnostics_driver.o \ + ../frame/module_domain.o + + +module_avgflx_em.o: \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_bc_em.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_big_step_utilities_em.o: \ + ../frame/module_configure.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_damping_em.o: \ + ../frame/module_wrf_error.o + + +module_diffusion_em.o: \ + ../share/module_bc.o \ + module_big_step_utilities_em.o \ + ../share/module_model_constants.o + + +module_em.o: \ + module_advect_em.o \ + module_big_step_utilities_em.o \ + ../frame/module_configure.o \ + module_damping_em.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + module_ieva_em.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o \ + ../share/module_trajectory.o + + +module_first_rk_step_part1.o: \ + module_big_step_utilities_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + module_convtrans_prep.o \ + ../phys/module_cumulus_driver.o \ + ../frame/module_domain.o \ + module_em.o \ + ../phys/module_fddagd_driver.o \ + module_force_scm.o \ + ../phys/module_fr_fire_driver_wrf.o \ + ../share/module_model_constants.o \ + ../phys/module_pbl_driver.o \ + ../phys/module_radiation_driver.o \ + ../phys/module_shallowcu_driver.o \ + ../phys/module_surface_driver.o + + +module_first_rk_step_part2.o: \ + ../share/module_bc.o \ + module_big_step_utilities_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + module_diffusion_em.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + module_em.o \ + ../phys/module_fddaobs_driver.o \ + ../share/module_model_constants.o \ + ../phys/module_physics_addtendc.o \ + module_sfs_driver.o \ + module_stoch.o + + +module_force_scm.o: \ + module_init_utilities.o + + +module_ieva_em.o: \ + ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_initialize_fire.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../phys/module_fr_fire_phys.o \ + ../phys/module_fr_fire_util.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_heldsuarez.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../frame/module_timing.o + + +module_initialize_ideal.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_real.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../share/module_date_time.o \ + ../frame/module_domain.o \ + ../share/module_io_domain.o \ + ../share/module_llxy.o \ + ../phys/module_madwrf.o \ + ../share/module_model_constants.o \ + ../share/module_optional_input.o \ + module_polarfft.o \ + ../phys/module_radiation_driver.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_scm_xy.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_optional_input.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_initialize_tropical_cyclone.o: \ + ../share/module_bc.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + module_init_utilities.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_soil_pre.o \ + ../frame/module_timing.o + + +module_polarfft.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o + + +module_positive_definite.o: \ + ../frame/module_wrf_error.o + + +module_sfs_driver.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_machine.o \ + ../share/module_model_constants.o \ + module_sfs_nba.o \ + ../frame/module_tiles.o + + +module_sfs_nba.o: \ + ../frame/module_configure.o + + +module_small_step_em.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o + + +module_stoch.o: \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o + + +module_wps_io_arw.o: \ + ../frame/module_domain.o \ + ../frame/module_internal_header_util.o \ + ../share/module_optional_input.o \ + ../share/module_soil_pre.o + + +nest_init_utils.o: \ + ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../frame/module_machine.o \ + ../share/module_model_constants.o \ + ../frame/module_tiles.o + + +shift_domain_em.o: \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_domain_type.o \ + ../frame/module_timing.o + + +solve_em.o: \ + module_after_all_rk_steps.o \ + module_avgflx_em.o \ + ../share/module_bc.o \ + module_bc_em.o \ + module_big_step_utilities_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../frame/module_cpl.o \ + module_diffusion_em.o \ + ../frame/module_domain.o \ + ../frame/module_domain_type.o \ + ../frame/module_driver_constants.o \ + ../phys/module_dust_emis.o \ + module_em.o \ + ../phys/module_fddaobs_driver.o \ + ../phys/module_firebrand_spotting.o \ + module_first_rk_step_part1.o \ + module_first_rk_step_part2.o \ + ../share/module_llxy.o \ + ../frame/module_machine.o \ + ../phys/module_microphysics_driver.o \ + ../phys/module_microphysics_zero_out.o \ + ../share/module_model_constants.o \ + ../phys/module_physics_addtendc.o \ + module_polarfft.o \ + module_small_step_em.o \ + module_solvedebug_em.o \ + ../frame/module_tiles.o + +start_em.o : \ + module_avgflx_em.o \ + ../share/module_bc.o \ + module_bc_em.o \ + ../frame/module_comm_dm.o \ + ../frame/module_configure.o \ + ../phys/module_diag_pld.o \ + ../phys/module_diag_zld.o \ + ../frame/module_domain.o \ + ../frame/module_driver_constants.o \ + ../phys/module_firebrand_spotting.o \ + ../phys/module_fr_fire_driver_wrf.o \ + ../phys/module_lightning_driver.o \ + ../share/module_llxy.o \ + ../share/module_model_constants.o \ + ../phys/module_physics_init.o \ + ../phys/noahmp/drivers/wrf/module_sf_noahmpdrv.o \ + module_stoch.o \ + ../frame/module_tiles.o \ + ../share/module_trajectory.o \ + ../frame/module_wrf_error.o diff --git a/phys/CMakeLists.txt b/phys/CMakeLists.txt new file mode 100644 index 0000000000..d7d85e1c12 --- /dev/null +++ b/phys/CMakeLists.txt @@ -0,0 +1,274 @@ +# WRF CMake Build + +######################################################################################################################## +# +# Quickly preprocess some files so that cmake can understand the module dependencies +# +######################################################################################################################## +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +wrf_c_preproc_fortran( + TARGET_NAME module_ra_rrtmg_preproc + OUTPUT_DIR ${CMAKE_CURRENT_BINARY_DIR}/preproc/ + EXTENSION ".f90" + INCLUDES ${CMAKE_CURRENT_SOURCE_DIR} + DEPENDENCIES registry_code + DEFINITIONS ${DIR_DEFS} + SOURCES module_ra_rrtmg_lwk.F + module_ra_rrtmg_lwf.F + module_ra_rrtmg_swk.F + module_ra_rrtmg_swf.F + module_sf_clm.F + ) + +add_dependencies( ${PROJECT_NAME}_Core module_ra_rrtmg_preproc ) + +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + ccpp_kind_types.F + complex_number_module.F + module_bep_bem_helper.F + module_bl_acm.F + module_bl_boulac.F + module_bl_camuwpbl_driver.F + module_bl_eepsilon.F + module_bl_fogdes.F + module_bl_gbmpbl.F + module_bl_gfs.F + module_bl_gfsedmf.F + module_bl_gwdo.F + module_bl_gwdo_gsl.F + module_bl_keps.F + module_bl_mfshconvpbl.F + module_bl_mrf.F + module_bl_myjpbl.F + module_bl_myjurb.F + module_bl_mynn.F + module_bl_mynn_common.F + module_bl_mynn_wrapper.F + module_bl_qnsepbl.F + module_bl_shinhong.F + module_bl_temf.F + module_bl_ysu.F + module_cam_bl_diffusion_solver.F + module_cam_bl_eddy_diff.F + module_cam_cldwat.F + module_cam_constituents.F + module_cam_error_function.F + module_cam_esinti.F + module_cam_gffgch.F + module_cam_infnan.F + module_cam_molec_diff.F + module_cam_mp_cldwat2m_micro.F + module_cam_mp_conv_water.F + module_cam_mp_microp_aero.F + module_cam_mp_modal_aero_initialize_data_phys.F + module_cam_mp_ndrop.F + module_cam_mp_qneg3.F + module_cam_mp_radconstants.F + module_cam_physconst.F + module_cam_shr_const_mod.F + module_cam_shr_kind_mod.F + module_cam_support.F + module_cam_trb_mtn_stress.F + module_cam_upper_bc.F + module_cam_wv_saturation.F + module_checkerror.F + module_cu_bmj.F + module_cu_camzm.F + module_cu_camzm_driver.F + module_cu_g3.F + module_cu_gd.F + module_cu_gf_ctrans.F + module_cu_gf_deep.F + module_cu_gf_sh.F + module_cu_gf_wrfdrv.F + module_cu_kf.F + module_cu_kfcup.F + module_cu_kfeta.F + module_cu_ksas.F + module_cu_mskf.F + module_cu_nsas.F + module_cu_ntiedtke.F + module_cu_osas.F + module_cu_sas.F + module_cu_scalesas.F + module_cu_tiedtke.F + module_cumulus_driver.F + module_data_cam_mam_aero.F + module_data_cam_mam_asect.F + module_data_gocart_dust.F + module_diag_afwa.F + module_diag_cl.F + module_diag_functions.F + module_diag_hailcast.F + module_diag_misc.F + module_diag_nwp.F + module_diag_pld.F + module_diag_rasm.F + module_diag_solar.F + module_diag_trad_fields.F + module_diag_zld.F + module_diagnostics_driver.F + module_dust_emis.F + module_fdda_psufddagd.F + module_fdda_spnudging.F + module_fddagd_driver.F + module_fddaobs_driver.F + module_fddaobs_rtfdda.F + module_fire_emis.F + module_firebrand_spotting.F + module_firebrand_spotting_mpi.F + module_fr_fire_atm.F + module_fr_fire_core.F + module_fr_fire_driver.F + module_fr_fire_driver_wrf.F + module_fr_fire_model.F + module_fr_fire_phys.F + module_fr_fire_util.F + module_gfs_funcphys.F + module_gfs_machine.F + module_gfs_physcons.F + module_gocart_coupling.F + module_irrigation.F + module_lightning_driver.F + module_ltng_cpmpr92z.F + module_ltng_crmpr92.F + module_ltng_iccg.F + module_ltng_lpi.F + module_madwrf.F + module_microphysics_driver.F + module_microphysics_zero_out.F + module_mixactivate.F + module_mp_cammgmp_driver.F + module_mp_etanew.F + module_mp_fast_sbm.F + module_mp_fer_hires.F + module_mp_full_sbm.F + module_mp_gsfcgce.F + module_mp_gsfcgce_4ice_nuwrf.F + module_mp_jensen_ishmael.F + module_mp_kessler.F + module_mp_lin.F + module_mp_milbrandt2mom.F + module_mp_morr_two_moment.F + module_mp_morr_two_moment_aero.F + module_mp_nssl_2mom.F + module_mp_ntu.F + module_mp_p3.F + module_mp_radar.F + module_mp_SBM_polar_radar.F + module_mp_sbu_ylin.F + module_mp_thompson.F + module_mp_wdm5.F + module_mp_wdm6.F + module_mp_wdm7.F + module_mp_wsm3.F + module_mp_wsm5.F + module_mp_wsm6.F + module_mp_wsm6r.F + module_mp_wsm7.F + module_pbl_driver.F + module_physics_addtendc.F + module_physics_init.F + module_progtm.F + module_ra_aerosol.F + module_ra_cam.F + module_ra_cam_support.F + module_ra_clWRF_support.F + module_ra_eclipse.F + module_ra_effective_radius.F + module_ra_farms.F + module_ra_flg.F + module_ra_gfdleta.F + module_ra_goddard.F + module_ra_gsfcsw.F + module_ra_hs.F + module_ra_rrtm.F + module_ra_rrtmg_aero_optical_util_cmaq.F + module_ra_rrtmg_lw.F + # module_ra_rrtmg_lwf.F + ${CMAKE_CURRENT_BINARY_DIR}/preproc/module_ra_rrtmg_lwf.f90 + # module_ra_rrtmg_lwk.F + ${CMAKE_CURRENT_BINARY_DIR}/preproc/module_ra_rrtmg_lwk.f90 + module_ra_rrtmg_sw.F + # module_ra_rrtmg_swf.F + ${CMAKE_CURRENT_BINARY_DIR}/preproc/module_ra_rrtmg_swf.f90 + # module_ra_rrtmg_swk.F + ${CMAKE_CURRENT_BINARY_DIR}/preproc/module_ra_rrtmg_swk.f90 + + module_ra_sw.F + module_radiation_driver.F + module_sf_3dpwp.F + module_sf_bem.F + module_sf_bep.F + module_sf_bep_bem.F + # module_sf_clm.F + ${CMAKE_CURRENT_BINARY_DIR}/preproc/module_sf_clm.f90 + module_sf_ctsm.F + module_sf_exchcoef.F + module_sf_fogdes.F + module_sf_gecros.F + module_sf_gfdl.F + module_sf_gfs.F + module_sf_idealscmsfclay.F + module_sf_lake.F + module_sf_myjsfc.F + module_sf_mynn.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 + # NoahMP Code + noahmp/drivers/wrf/module_sf_noahmpdrv.F + noahmp/src/module_sf_noahmp_glacier.F + noahmp/src/module_sf_noahmp_groundwater.F + noahmp/src/module_sf_noahmplsm.F + + module_sf_ocean_driver.F + module_sf_oml.F + module_sf_pxlsm.F + module_sf_pxlsm_data.F + module_sf_pxsfclay.F + module_sf_qnsesfc.F + module_sf_ruclsm.F + module_sf_scmflux.F + module_sf_scmskintemp.F + module_sf_sfcdiags.F + module_sf_sfcdiags_ruclsm.F + module_sf_sfclay.F + module_sf_sfclayrev.F + module_sf_slab.F + module_sf_ssib.F + module_sf_sstskin.F + module_sf_temfsfclay.F + module_sf_tmnupdate.F + module_sf_urban.F + module_shallowcu_driver.F + module_shcu_camuwshcu.F + module_shcu_camuwshcu_driver.F + module_shcu_deng.F + module_shcu_grims.F + module_shcu_nscv.F + module_surface_driver.F + module_wind_fitch.F + module_wind_mav.F + + # Shared physics + physics_mmm/bl_gwdo.F90 + physics_mmm/bl_ysu.F90 + physics_mmm/cu_ntiedtke.F90 + physics_mmm/module_libmassv.F90 + physics_mmm/mp_radar.F90 + physics_mmm/mp_wsm6.F90 + physics_mmm/mp_wsm6_effectRad.F90 + physics_mmm/sf_sfclayrev.F90 + ) + + +target_include_directories( + ${PROJECT_NAME}_Core + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) \ No newline at end of file diff --git a/phys/Makefile b/phys/Makefile index 3c0c85ee68..6da65a82f3 100644 --- a/phys/Makefile +++ b/phys/Makefile @@ -6,6 +6,7 @@ RM = rm -f MODULES = \ + ccpp_kind_types.o \ module_bep_bem_helper.o \ complex_number_module.o \ module_cam_shr_kind_mod.o \ @@ -203,6 +204,7 @@ MODULES = \ module_fddaobs_rtfdda.o \ module_fddaobs_driver.o \ module_wind_fitch.o \ + module_wind_mav.o \ module_sf_lake.o \ module_diagnostics_driver.o \ module_diagvar_cordex.o \ @@ -233,6 +235,16 @@ DIAGNOSTIC_MODULES_EM = \ module_diag_trad_fields.o \ module_diag_solar.o +PHYSMMM_MODULES = \ + physics_mmm/sf_sfclayrev.o \ + physics_mmm/cu_ntiedtke.o \ + physics_mmm/module_libmassv.o \ + physics_mmm/mp_wsm6.o \ + physics_mmm/mp_wsm6_effectRad.o \ + physics_mmm/mp_radar.o \ + physics_mmm/bl_gwdo.o \ + physics_mmm/bl_ysu.o + OBJS = LIBTARGET = physics @@ -241,11 +253,11 @@ TARGETDIR = ./ $(LIBTARGET) : $(MAKE) $(J) non_nmm ; \ $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \ - $(FIRE_MODULES) $(DIAGNOSTIC_MODULES_EM) + $(FIRE_MODULES) $(DIAGNOSTIC_MODULES_EM) $(PHYSMMM_MODULES) include ../configure.wrf -non_nmm : $(MODULES) $(FIRE_MODULES) $(WIND_MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_EM) +non_nmm : $(MODULES) $(FIRE_MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_EM) submodules : @if [ \( ! -f module_sf_noahmpdrv.F \) -o \( ! -f module_sf_noahmp_glacier.F \) -o \ diff --git a/phys/ccpp_kind_types.F b/phys/ccpp_kind_types.F new file mode 100644 index 0000000000..9360bbf67e --- /dev/null +++ b/phys/ccpp_kind_types.F @@ -0,0 +1,8 @@ +module ccpp_kind_types +#if ( RWORDSIZE == 4 ) + integer, parameter :: kind_phys = selected_real_kind(6) +#else + integer, parameter :: kind_phys = selected_real_kind(12) +#endif + contains +end module ccpp_kind_types diff --git a/phys/module_bl_gwdo.F b/phys/module_bl_gwdo.F index c81e67c33e..81026c6404 100644 --- a/phys/module_bl_gwdo.F +++ b/phys/module_bl_gwdo.F @@ -1,21 +1,32 @@ -!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, & - 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) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- +!================================================================================================================= + module module_bl_gwdo + use ccpp_kind_types,only: kind_phys + + use bl_gwdo,only: bl_gwdo_run + + + implicit none + private + public:: 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, & + 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) @@ -56,672 +67,177 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & !-- 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 -! - real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi -! - 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, & - sina,cosa -! - 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 ) :: ugeo, vgeo, dudt, dvdt, dtaux, dtauy - real, dimension( its:ite ) :: dusfc, dvsfc - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite, 4 ) :: oa4, & - ol4 - integer :: i,j,k,kpblmax -! - do k = kts,kte - if (znu(k).gt.0.6) kpblmax = k + 1 - enddo -! - do j = jts,jte - 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 -! - do k = kts,kte - do i = its,ite - delprsi(i,k) = pdhi(i,k)-pdhi(i,k+1) -! rotate winds to zonal/meridional - ugeo(i,k) = u3d(i,k,j)*cosa(i,j) - v3d(i,k,j)*sina(i,j) - vgeo(i,k) = u3d(i,k,j)*sina(i,j) + v3d(i,k,j)*cosa(i,j) - dudt(i,k) = 0.0 - dvdt(i,k) = 0.0 - 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=dudt(its,kts),dvdt=dvdt(its,kts) & - ,dtaux2d=dtaux(its,kts),dtauy2d=dtauy(its,kts) & - ,u1=ugeo(its,kts),v1=vgeo(its,kts) & - ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) & - ,del=delprsi(its,kts) & - ,prsi=pdhi(its,kts) & - ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) & - ,zl=z(ims,kms,j) & - ,kpblmax=kpblmax & - ,var=var2d(ims,j),oc1=oc12d(ims,j) & - ,oa4=oa4,ol4=ol4 & - ,dusfc=dusfc(its),dvsfc=dvsfc(its) & - ,g_=g,cp_=cp,rd_=rd,rv_=rv,fv_=ep1,pi_=pi & - ,dxmeter=dx,deltim=dt & - ,kpbl=kpbl2d(ims,j),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 ) - do k = kts,kte - do i = its,ite -! rotate tendencies from zonal/meridional to model grid - rublten(i,k,j) = rublten(i,k,j)+dudt(i,k)*cosa(i,j) + dvdt(i,k)*sina(i,j) - rvblten(i,k,j) = rvblten(i,k,j)-dudt(i,k)*sina(i,j) + dvdt(i,k)*cosa(i,j) - dtaux3d(i,k,j) = dtaux(i,k)*cosa(i,j) + dtauy(i,k)*sina(i,j) - dtauy3d(i,k,j) =-dtaux(i,k)*sina(i,j) + dtauy(i,k)*cosa(i,j) - if(k.eq.kts)then - dusfcg(i,j) = dusfc(i)*cosa(i,j) + dvsfc(i)*sina(i,j) - dvsfcg(i,j) =-dusfc(i)*sina(i,j) + dvsfc(i)*cosa(i,j) - endif - enddo - enddo - enddo -! - end subroutine gwdo -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- - subroutine gwdo2d(dudt, dvdt, dtaux2d, dtauy2d, & - u1, v1, t1, q1, & - del, & - prsi, prsl, prslk, zl, & - kpblmax, & - var, oc1, oa4, ol4, dusfc, dvsfc, & - g_, cp_, rd_, rv_, fv_, pi_, & - dxmeter, deltim, kpbl, lat, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) -!------------------------------------------------------------------------------- -! -! abstract : -! 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 -! choi and hong (2015), which names kim gwdo since it was developed by -! kiaps staffs for kiaps integrated model system (kim). the scheme -! additionally includes the effects of orographic anisotropy and -! flow-blocking drag. -! coded by song-you hong and young-joon kim and implemented by song-you hong -! -! history log : -! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy -! -! references : -! choi and hong (2015), j. geophys. res. -! hong et al. (2008), wea. forecasting -! kim and doyle (2005), q. j. r. meteor. soc. -! kim and arakawa (1995), j. atmos. sci. -! alpet et al. (1988), NWP conference -! hong (1999), NCEP office note 424 -! -! input : -! dudt, dvdt - non-lin tendency for u and v wind component -! u1, v1 - zonal and meridional wind m/sec at t0-dt -! t1 - temperature deg k at t0-dt -! q1 - mixing ratio at t0-dt -! deltim - time step (s) -! del - positive increment of pressure across layer (pa) -! kpblmax, kpbl - vertical index of pbl height -! prslk, zl, prsl, prsi - pressure and height variables -! oa4, ol4, omax, var, oc1 - orographic statistics -! -! output : -! dudt, dvdt - wind tendency due to gwdo -! dtaux2d, dtauy2d - diagnoised orographic gwd -! dusfc, dvsfc - gw stress -! -!------------------------------------------------------------------------------- - implicit none -! - integer , intent(in ) :: lat, kpblmax, & - ids, ide, jds, jde, & - kds, kde, ims, ime, & - jms, jme, kms, kme, & - its, ite, jts, jte, & - kts, kte - integer, dimension(ims:ime) , intent(in ) :: kpbl - real , intent(in ) :: g_, pi_, rd_, rv_, fv_,& - cp_, deltim - real , intent(in ) :: dxmeter - real, dimension(its:ite,kts:kte) , intent(inout) :: dudt, dvdt - real, dimension(its:ite,kts:kte) , intent( out) :: dtaux2d, dtauy2d - real, dimension(its:ite,kts:kte) , intent(in ) :: u1, v1 - real, dimension(ims:ime,kms:kme) , intent(in ) :: t1, q1, prslk, zl -! - real, dimension(its:ite,kts:kte) , intent(in ) :: prsl, del - real, dimension(its:ite,kts:kte+1), intent(in ) :: prsi - real, dimension(its:ite,4) , intent(in ) :: oa4, ol4 -! - real, dimension(ims:ime) , intent(in ) :: var, oc1 - real, dimension(its:ite) , intent( out) :: dusfc, dvsfc -! - real, parameter :: ric = 0.25 ! critical richardson number - 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 :: frc = 1.0 - real, parameter :: ce = 0.8 - real, parameter :: cg = 0.5 - integer,parameter :: kpblmin = 2 -! -! local variables -! - integer :: latd,lond - integer :: i,k,lcap,lcapp1,nwd,idir, & - klcap,kp1,ikount,kk -! - real :: fdir,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & - temv,dtaux,dtauy -! - logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 - real, dimension(its:ite) :: coefm -! - real, dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & - ulow, rulow, bnv, oa, ol, rhobar, & - dtfac, brvf, xlinv, delks,delks1, & - zlowtop,cleff - real, dimension(its:ite,kts:kte+1) :: taup - real, dimension(its:ite,kts:kte-1) :: velco - real, dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj -! - integer, dimension(its:ite) :: kbl, klowtop - integer, parameter :: mdir=8 - integer, dimension(mdir) :: nwdir - data nwdir/6,7,5,8,2,3,1,4/ -! -! variables for flow-blocking drag -! - real, parameter :: frmax = 10. - real, parameter :: olmin = 1.0e-5 - real, parameter :: odmin = 0.1 - real, parameter :: odmax = 10. -! - real :: fbdcd - real :: zblk, tautem - real :: fbdpe, fbdke - real, dimension(its:ite) :: delx, dely - real, dimension(its:ite,4) :: dxy4, dxy4p - real, dimension(4) :: ol4p - real, dimension(its:ite) :: dxy, dxyp, olp, od - real, dimension(its:ite,kts:kte+1) :: taufb -! - integer, dimension(its:ite) :: komax - integer :: kblk -!------------------------------------------------------------------------------- -! -! constants -! - lcap = kte - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi_) -! -! calculate length of grid for flow-blocking drag -! - delx(its:ite) = dxmeter - dely(its:ite) = dxmeter - dxy4(its:ite,1) = delx(its:ite) - dxy4(its:ite,2) = dely(its:ite) - dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) - dxy4(its:ite,4) = dxy4(its:ite,3) - dxy4p(its:ite,1) = dxy4(its:ite,2) - dxy4p(its:ite,2) = dxy4(its:ite,1) - dxy4p(its:ite,3) = dxy4(its:ite,4) - dxy4p(its:ite,4) = dxy4(its:ite,3) -! - cleff(its:ite) = dxmeter -! -! initialize arrays -! - ldrag = .false. ; icrilv = .false. ; flag = .true. -! - klowtop = 0 ; kbl = 0 -! - dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. - ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. - oa = 0. ; ol = 0. ; taub = 0. -! - usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. - taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. -! - dtfac = 1.0 ; xlinv = 1.0/xl -! -! initialize arrays for flow-blocking drag -! - komax = 0 - taufb = 0.0 -! - 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) - rho(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 -! - 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 -! - do i = its,ite -! -! determine reference level: 2*var -! - kbl(i) = klowtop(i) - kbl(i) = max(min(kbl(i),kpblmax),kpblmin) - enddo -! -! determine the level of maximum orographic height -! - komax(:) = kbl(:) -! - 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 -! -! compute low level averages within pbl -! - do k = kts,kpblmax - do i = its,ite - if (k.lt.kbl(i)) then - rcsks = del(i,k) * delks(i) - rdelks = 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 - rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho 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) -! -! compute orographic width along (ol) and perpendicular (olp) the wind direction -! - ol4p(1) = ol4(i,2) - ol4p(2) = ol4(i,1) - ol4p(3) = ol4(i,4) - ol4p(4) = ol4(i,3) - olp(i) = ol4p(mod(nwd-1,4)+1) -! -! compute orographic direction (horizontal orographic aspect ratio) -! - od(i) = olp(i)/max(ol(i),olmin) - od(i) = min(od(i),odmax) - od(i) = max(od(i),odmin) -! -! compute length of grid in the along(dxy) and cross(dxyp) wind directions -! - dxy(i) = dxy4(i,MOD(nwd-1,4)+1) - dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) - 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 = 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.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - 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 * ((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 -! -! no drag when velco.lt.0 -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.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 phy_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 = kpblmin,kpblmax - 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 = kpblmin,kpblmax - 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) * od(i) - fr(i) = min(fr(i),frmax) - 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(i) = (1. + ol(i)) ** (oa(i)+1.) - xlinv(i) = coefm(i) / cleff(i) - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - taub(i) = xlinv(i) * rhobar(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. -! - 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 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(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. kpblmin )) 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 - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - enddo - endif - do i = its,ite - if (.not.ldrag(i)) then -! -! determine the height of flow-blocking layer -! - kblk = 0 - fbdpe = 0.0 - fbdke = 0.0 - do k = kte, kpblmin, -1 - if (kblk.eq.0 .and. k.le.kbl(i)) then - fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & - *del(i,k)/g_/rho(i,k) - fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) -! -! apply flow-blocking drag when fbdpe >= fbdke -! - if (fbdpe.ge.fbdke) then - kblk = k - kblk = min(kblk,kbl(i)) - zblk = zl(i,kblk)-zl(i,kts) - endif - endif +!================================================================================================================= + +!--- 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 + p3di_hv(i,k) = p3di(i,k,j) enddo - if (kblk.ne.0) then -! -! compute flow-blocking stress -! - fbdcd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter**2*fbdcd*dxyp(i) & - *olp(i)*zblk*ulow(i)**2 - tautem = taufb(i,kts)/real(kblk-kts) - do k = kts+1, kblk - taufb(i,k) = taufb(i,k-1) - tautem - enddo -! -! sum orographic GW stress and flow-blocking stress -! - taup(i,:) = taup(i,:) + taufb(i,:) - endif - endif - enddo -! -! 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)) * g_ / del(i,k) - 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*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_) * dusfc(i) - dvsfc(i) = (-1./g_) * 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/phys/module_bl_mynn.F b/phys/module_bl_mynn.F index e1bf567411..c1ea9c6417 100644 --- a/phys/module_bl_mynn.F +++ b/phys/module_bl_mynn.F @@ -121,7 +121,7 @@ ! Hybrid PBL height diagnostic, which blends a theta-v-based ! definition in neutral/convective BL and a TKE-based definition ! in stable conditions. -! TKE budget output option (bl_mynn_tkebudget) +! TKE budget output option ! v3.5.0: TKE advection option (bl_mynn_tkeadvect) ! v3.5.1: Fog deposition related changes. ! v3.6.0: Removed fog deposition from the calculation of tendencies @@ -232,13 +232,26 @@ ! bl_mynn_cloudpdf = 2 (Chab-Becht). ! Removed WRF_CHEM dependencies. ! Many miscellaneous tweaks. +! v4.6 / CCPP +! Some code optimization. Removed many conditions from loops. Redesigned the mass- +! flux scheme to use 8 plumes instead of a variable n plumes. This results in +! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. +! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all +! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility +! for tuning near-surface cloud fractions to remove excess fog/low ceilings. +! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This +! results in a change in the pre-radiation code to no longer multiply mixing ratios +! by cloud fractions. +! Bug fix for the momentum transport. +! Lots of code cleanup: removal of test code, comments, changing text case, etc. +! Many misc tuning/tweaks. ! ! Many of these changes are now documented in references listed above. !==================================================================== MODULE module_bl_mynn - use module_bl_mynn_common,only: & + use module_bl_mynn_common,only: & cp , cpv , cliq , cice , & p608 , ep_2 , ep_3 , gtr , & grav , g_inv , karman , p1000mb , & @@ -256,45 +269,45 @@ MODULE module_bl_mynn !=================================================================== ! From here on, these are MYNN-specific parameters: ! 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(kind_phys), parameter :: cphm_st=5.0, cphm_unst=16.0, & + cphh_st=5.0, cphh_unst=16.0 ! Closure constants - REAL, PARAMETER :: & - &pr = 0.74, & - &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & + real(kind_phys), parameter :: & + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 + &b1 = 24.0, & + &b2 = 15.0, & ! CKmod NN2009 + &c2 = 0.729, & ! 0.729, & !0.75, & + &c3 = 0.340, & ! 0.340, & !0.352, & + &c4 = 0.0, & + &c5 = 0.2, & &a1 = b1*( 1.0-3.0*g1 )/6.0, & ! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & &a2 = a1*( g1-c1 )/( g1*pr ), & &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - REAL, PARAMETER :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & + real(kind_phys), parameter :: & + &cc2 = 1.0-c2, & + &cc3 = 1.0-c3, & + &e1c = 3.0*a2*b2*cc3, & + &e2c = 9.0*a1*a2*cc2, & &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & + &e4c = 12.0*a1*a2*cc2, & &e5c = 6.0*a1*a1 ! Constants for min tke in elt integration (qmin), max z/L in els (zmax), ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 + real(kind_phys), parameter :: qmin=0.0, zmax=1.0, Sqfac=3.0 ! Note that the following mixing-length constants are now specified in mym_length ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 - REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq + real(kind_phys), parameter :: qkemin=1.e-3 + real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) - REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 + real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423 !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the @@ -304,61 +317,34 @@ MODULE module_bl_mynn !!(above) back to NN2009 values (see commented out lines next to the !!parameters above). This only removes the negative TKE problem !!but does not necessarily improve performance - neutral impact. - REAL, PARAMETER :: CKmod=1. + real(kind_phys), parameter :: CKmod=1. !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts - !!on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function - !!for TKE in the upper PBL/cloud layer. - REAL, PARAMETER :: scaleaware=1. + !!on the cloud PDF and mass-flux scheme, using LES-derived similarity function. + real(kind_phys), parameter :: scaleaware=1. !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling - INTEGER, PARAMETER :: bl_mynn_topdown = 0 + integer, parameter :: bl_mynn_topdown = 0 !>Option to activate downdrafts, from Elynn Wu (0: deactive, 1: active) - INTEGER, PARAMETER :: bl_mynn_edmf_dd = 0 + integer, parameter :: bl_mynn_edmf_dd = 0 !>Option to activate heating due to dissipation of TKE (to activate, set to 1.0) - INTEGER, PARAMETER :: dheat_opt = 1 + integer, parameter :: dheat_opt = 1 !Option to activate environmental subsidence in mass-flux scheme - LOGICAL, PARAMETER :: env_subs = .false. + logical, parameter :: env_subs = .false. !Option to switch flux-profile relationship for surface (from Puhales et al. 2020) !0: use original Dyer-Hicks, 1: use Cheng-Brustaert and Blended COARE - INTEGER, PARAMETER :: bl_mynn_stfunc = 1 + integer, parameter :: bl_mynn_stfunc = 1 !option to print out more stuff for debugging purposes - LOGICAL, PARAMETER :: debug_code = .false. - INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out - -! JAYMES- -!> Constants used for empirical calculations of saturation -!! vapor pressures (in function "esat") and saturation mixing ratios -!! (in function "qsat"), reproduced from module_mp_thompson.F, -!! v3.6 - REAL, PARAMETER:: J0= .611583699E03 - REAL, PARAMETER:: J1= .444606896E02 - REAL, PARAMETER:: J2= .143177157E01 - REAL, PARAMETER:: J3= .264224321E-1 - REAL, PARAMETER:: J4= .299291081E-3 - REAL, PARAMETER:: J5= .203154182E-5 - REAL, PARAMETER:: J6= .702620698E-8 - REAL, PARAMETER:: J7= .379534310E-11 - REAL, PARAMETER:: J8=-.321582393E-13 - - REAL, PARAMETER:: K0= .609868993E03 - REAL, PARAMETER:: K1= .499320233E02 - REAL, PARAMETER:: K2= .184672631E01 - REAL, PARAMETER:: K3= .402737184E-1 - REAL, PARAMETER:: K4= .565392987E-3 - REAL, PARAMETER:: K5= .521693933E-5 - REAL, PARAMETER:: K6= .307839583E-7 - REAL, PARAMETER:: K7= .105785160E-9 - REAL, PARAMETER:: K8= .161444444E-12 -! end- + logical, parameter :: debug_code = .false. + integer, parameter :: idbg = 23 !specific i-point to write out ! Used in WRF-ARW module_physics_init.F - INTEGER :: mynn_level + integer :: mynn_level CONTAINS @@ -375,7 +361,7 @@ SUBROUTINE mynn_bl_driver( & &initflag,restart,cycling, & &delt,dz,dx,znt, & &u,v,w,th,sqv3d,sqc3d,sqi3d, & - &qnc,qni, & + &sqs3d,qnc,qni, & &qnwfa,qnifa,qnbca,ozone, & &p,exner,rho,t3d, & &xland,ts,qsfc,ps, & @@ -391,7 +377,7 @@ SUBROUTINE mynn_bl_driver( & &tsq,qsq,cov, & &rublten,rvblten,rthblten, & &rqvblten,rqcblten,rqiblten, & - &rqncblten,rqniblten, & + &rqncblten,rqniblten,rqsblten, & &rqnwfablten,rqnifablten, & &rqnbcablten,dozone, & &exch_h,exch_m, & @@ -415,44 +401,47 @@ SUBROUTINE mynn_bl_driver( & &edmf_thl,edmf_ent,edmf_qc, & &sub_thl3D,sub_sqv3D, & &det_thl3D,det_sqv3D, & - &nupdraft,maxMF,ktop_plume, & + &maxwidth,maxMF,ztop_plume, & + &ktop_plume, & &spp_pbl,pattern_spp_pbl, & &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_QNBCA, & + &FLAG_QNI,FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_QNBCA,FLAG_OZONE, & &IDS,IDE,JDS,JDE,KDS,KDE, & &IMS,IME,JMS,JME,KMS,KME, & &ITS,ITE,JTS,JTE,KTS,KTE ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: initflag + integer, intent(in) :: initflag !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(in) :: restart,cycling - INTEGER, INTENT(in) :: tke_budget - INTEGER, INTENT(in) :: bl_mynn_cloudpdf - INTEGER, INTENT(in) :: bl_mynn_mixlength - INTEGER, INTENT(in) :: bl_mynn_edmf - LOGICAL, INTENT(in) :: bl_mynn_tkeadvect - INTEGER, INTENT(in) :: bl_mynn_edmf_mom - INTEGER, INTENT(in) :: bl_mynn_edmf_tke - INTEGER, INTENT(in) :: bl_mynn_mixscalars - INTEGER, INTENT(in) :: bl_mynn_output - INTEGER, INTENT(in) :: bl_mynn_cloudmix - INTEGER, INTENT(in) :: bl_mynn_mixqt - INTEGER, INTENT(in) :: icloud_bl - REAL, INTENT(in) :: closure - - LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA - - LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - - INTEGER, INTENT(in) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE + logical, intent(in) :: restart,cycling + integer, intent(in) :: tke_budget + integer, intent(in) :: bl_mynn_cloudpdf + integer, intent(in) :: bl_mynn_mixlength + integer, intent(in) :: bl_mynn_edmf + logical, intent(in) :: bl_mynn_tkeadvect + integer, intent(in) :: bl_mynn_edmf_mom + integer, intent(in) :: bl_mynn_edmf_tke + integer, intent(in) :: bl_mynn_mixscalars + integer, intent(in) :: bl_mynn_output + integer, intent(in) :: bl_mynn_cloudmix + integer, intent(in) :: bl_mynn_mixqt + integer, intent(in) :: icloud_bl + real(kind_phys), intent(in) :: closure + + logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + FLAG_OZONE,FLAG_QS + + logical, intent(in) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg + + integer, intent(in) :: & + & IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE #ifdef HARDCODE_VERTICAL # define kts 1 @@ -464,124 +453,135 @@ SUBROUTINE mynn_bl_driver( & ! closure : <= 2.5; Level 2.5 ! 2.5< and <3; Level 2.6 ! = 3; Level 3 + +! SGT: Changed this to use assumed shape arrays (dimension(:,:,:)) with no "optional" arguments +! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs +! on Cheyenne with the GNU compiler. - REAL, INTENT(in) :: delt - REAL, DIMENSION(IMS:IME), INTENT(in) :: dx - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: dz, & - &u,v,w,th,sqv3D,p,exner,rho,t3d - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: & - &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa,qnbca - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(in):: ozone - REAL, DIMENSION(IMS:IME), INTENT(in) :: xland,ust, & - &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,znt - - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &qke,tsq,qsq,cov,qke_adv - - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &rublten,rvblten,rthblten,rqvblten,rqcblten, & - &rqiblten,rqniblten,rqncblten, & + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(ims:ime), intent(in) :: dx + real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: dz, & + &u,v,w,th,sqv3D,p,exner,rho,T3D + real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: & + &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca + real(kind_phys), dimension(ims:ime,kms:kme), optional,intent(in):: ozone + real(kind_phys), dimension(ims:ime), intent(in):: ust, & + &ch,qsfc,ps,wspd + real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & + &Qke,Tsq,Qsq,Cov,qke_adv + real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqsblten,rqniblten,rqncblten, & &rqnwfablten,rqnifablten,rqnbcablten - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: dozone - - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(in) :: rthraten + real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: dozone + real(kind_phys), dimension(ims:ime,kms:kme), intent(in) :: rthraten - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(out) :: & - &exch_h,exch_m + real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: exch_h,exch_m + real(kind_phys), dimension(ims:ime), intent(in) :: xland, & + &ts,znt,hfx,qfx,uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(IMS:IME,KMS:KME), OPTIONAL, INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D -! REAL, DIMENSION(IMS:IME,KMS:KME) :: & +! real, dimension(ims:ime,kms:kme) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(IMS:IME), INTENT(inout) :: pblh,rmol + real(kind_phys), dimension(ims:ime), intent(inout) :: pblh + real(kind_phys), dimension(ims:ime), intent(inout) :: rmol - REAL, DIMENSION(IMS:IME) :: psig_bl,psig_shcu + real(kind_phys), dimension(ims:ime) :: psig_bl,psig_shcu - INTEGER,DIMENSION(IMS:IME),INTENT(INOUT) :: & - &kpbl,nupdraft,ktop_plume + integer,dimension(ims:ime),intent(inout) :: & + &KPBL,ktop_plume - REAL, DIMENSION(IMS:IME), INTENT(OUT) :: & - &maxmf + real(kind_phys), dimension(ims:ime), intent(out) :: & + &maxmf,maxwidth,ztop_plume - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & - &el_pbl + real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: el_pbl - REAL, DIMENSION(IMS:IME,KMS:KME), optional, INTENT(out) :: & - &qwt,qshear,qbuoy,qdiss,dqke + real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(inout) :: & + &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(kts:kte) :: qwt1,qshear1,qbuoy1,qdiss1, & - &dqke1,diss_heat + real(kind_phys), dimension(kts:kte) :: & + &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - REAL, DIMENSION(IMS:IME,KMS:KME), intent(out) :: Sh3D,Sm3D + real(kind_phys), dimension(ims:ime,kms:kme), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(IMS:IME,KMS:KME), INTENT(inout) :: & + real(kind_phys), dimension(ims:ime,kms:kme), intent(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& - qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old + real(kind_phys), dimension(kts:kte) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays - INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel - REAL, DIMENSION(ims:ime, kms:kme, nchem), INTENT(INOUT), optional :: chem3d - REAL, DIMENSION(ims:ime, ndvel), INTENT(IN), optional :: vdep - REAL, DIMENSION(ims:ime), INTENT(IN), optional :: frp,EMIS_ANT_NO + integer, intent(IN ) :: nchem, kdvel, ndvel + real(kind_phys), dimension(ims:ime,kms:kme,nchem), optional, intent(inout) :: chem3d + real(kind_phys), dimension(ims:ime, ndvel), optional, intent(in) :: vdep + real(kind_phys), dimension(ims:ime), optional, intent(in) :: frp,EMIS_ANT_NO !local - REAL, DIMENSION(kts:kte ,nchem) :: chem1 - REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 - REAL, DIMENSION(ndvel) :: vd1 - INTEGER :: ic + real(kind_phys), dimension(kts:kte ,nchem) :: chem1 + real(kind_phys), dimension(kts:kte+1,nchem) :: s_awchem1 + real(kind_phys), dimension(ndvel) :: vd1 + integer :: ic !local vars - INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k,kproblem - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& + integer :: ITF,JTF,KTF, IMD,JMD + integer :: i,j,k,kproblem + real(kind_phys), dimension(kts:kte) :: & + &thl,tl,qv1,qc1,qi1,qs1,sqw, & &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & - &vt, vq, sgm, thlsg, sqwsg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & + &vt, vq, sgm, kzero + real(kind_phys), dimension(kts:kte) :: & + &thetav,sh,sm,u1,v1,w1,p1, & &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &sqv,sqi,sqc,sqs, & + &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, & &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 !mass-flux variables - REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & - &edmf_thl1,edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & - &edmf_qt_dd1,edmf_thl_dd1, & + real(kind_phys), dimension(kts:kte) :: & + &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + real(kind_phys), dimension(kts:kte) :: & + &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & + &edmf_ent1,edmf_qc1 + real(kind_phys), dimension(kts:kte) :: & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,& - det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & - s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & - s_awqnbca1 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & - sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - - REAL, DIMENSION(KTS:KTE+1) :: zw - REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& - & afk,abk,ts_decay, qc_bl2, qi_bl2, & - & th_sfc,ztop_plume,sqc9,sqi9,wsp + real(kind_phys), dimension(kts:kte) :: & + &sub_thl,sub_sqv,sub_u,sub_v, & + &det_thl,det_sqv,det_sqc,det_u,det_v + real(kind_phys), dimension(kts:kte+1) :: & + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & + &s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & + &s_awqnbca1 + real(kind_phys), dimension(kts:kte+1) :: & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 + + real(kind_phys), dimension(kts:kte+1) :: zw + real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, & + &pmz,phh,exnerg,zet,phi_m, & + &afk,abk,ts_decay, qc_bl2, qi_bl2, & + &th_sfc,wsp !top-down diffusion - REAL, DIMENSION(ITS:ITE) :: maxKHtopdown - REAL, DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD + real(kind_phys), dimension(ITS:ITE) :: maxKHtopdown + real(kind_phys), dimension(kts:kte) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE,problem + logical :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) ::rstoch_col + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(ims:ime,kms:kme), optional, intent(in) :: pattern_spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col ! Substepping TKE - INTEGER :: nsub - real :: delt2 + integer :: nsub + real(kind_phys) :: delt2 if (debug_code) then !check incoming values @@ -618,7 +618,7 @@ SUBROUTINE mynn_bl_driver( & !*** Begin debugging IMD=(IMS+IME)/2 JMD=(JMS+JME)/2 -!*** End debugging +!*** End debugging JTF=JTE ITF=ITE @@ -644,9 +644,11 @@ SUBROUTINE mynn_bl_driver( & !edmf_qc_dd(its:ite,kts:kte)=0. ENDIF ktop_plume(its:ite)=0 !int - nupdraft(its:ite)=0 !int + ztop_plume(its:ite)=0. + maxwidth(its:ite)=0. maxmf(its:ite)=0. maxKHtopdown(its:ite)=0. + kzero(kts:kte)=0. ! DH* CHECK HOW MUCH OF THIS INIT IF-BLOCK IS ACTUALLY NEEDED FOR RESTARTS !> - Within the MYNN-EDMF, there is a dependecy check for the first time step, @@ -724,7 +726,23 @@ SUBROUTINE mynn_bl_driver( & ENDIF DO i=ITS,ITF - DO k=KTS,KTE !KTF + if (FLAG_QI ) then + sqi(:)=sqi3D(i,:) + else + sqi = 0.0 + endif + if (FLAG_QS ) then + sqs(:)=sqs3D(i,:) + else + sqs = 0.0 + endif + if (icloud_bl > 0) then + cldfra_bl1d(:)=cldfra_bl(i,:) + qc_bl1d(:)=qc_bl(i,:) + qi_bl1d(:)=qi_bl(i,:) + endif + + do k=KTS,KTE !KTF dz1(k)=dz(i,k) u1(k) = u(i,k) v1(k) = v(i,k) @@ -735,52 +753,15 @@ SUBROUTINE mynn_bl_driver( & rho1(k)=rho(i,k) sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) - thetav(k)=th(i,k)*(1.+0.608*sqv(k)) - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - ENDIF - IF (FLAG_QI ) THEN - sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) - sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - sqi(k)=0.0 - sqw(k)=sqv(k)+sqc(k) - thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=0.0 - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ENDIF - thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) + thetav(k)=th(i,k)*(1.+p608*sqv(k)) + !keep snow out for now - increases ceiling bias + sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) + thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) IF (k==kts) THEN zw(k)=0. @@ -811,7 +792,7 @@ SUBROUTINE mynn_bl_driver( & zw(kte+1)=zw(kte)+dz(i,kte) -!> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height. +!> - Call get_pblh() to calculate hybrid (\f$\theta_{v}-TKE\f$) PBL height. CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& & Qke1,zw,dz1,xland(i),KPBL(i)) @@ -833,7 +814,6 @@ SUBROUTINE mynn_bl_driver( & &kts,kte,xland(i), & &dz1, dx(i), zw, & &u1, v1, thl, sqv, & - &thlsg, sqwsg, & &PBLH(i), th1, thetav, sh, sm, & &ust(i), rmol(i), & &el, Qke1, Tsq1, Qsq1, Cov1, & @@ -841,7 +821,7 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixlength, & &edmf_w1,edmf_a1, & &INITIALIZE_QKE, & - &spp_pbl,rstoch_col ) + &spp_pbl,rstoch_col ) IF (.not.restart) THEN !UPDATE 3D VARIABLES @@ -884,647 +864,580 @@ SUBROUTINE mynn_bl_driver( & ENDIF DO i=ITS,ITF - DO k=KTS,KTE !KTF - !JOE-TKE BUDGET - IF (tke_budget .eq. 1) THEN - dqke(i,k)=qke(i,k) - END IF - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - cldfra_bl1D_old(k)=cldfra_bl(i,k) - qc_bl1D_old(k)=qc_bl(i,k) - qi_bl1D_old(k)=qi_bl(i,k) - else - CLDFRA_BL1D(k)=0.0 - QC_BL1D(k)=0.0 - QI_BL1D(k)=0.0 - cldfra_bl1D_old(k)=0.0 - qc_bl1D_old(k)=0.0 - qi_bl1D_old(k)=0.0 - ENDIF - dz1(k)= dz(i,k) - u1(k) = u(i,k) - v1(k) = v(i,k) - w1(k) = w(i,k) - th1(k)= th(i,k) - tk1(k)=T3D(i,k) - p1(k) = p(i,k) - ex1(k)= exner(i,k) - rho1(k)=rho(i,k) - sqv(k)= sqv3D(i,k) !/(1.+qv(i,k)) - sqc(k)= sqc3D(i,k) !/(1.+qv(i,k)) - qv1(k)= sqv(k)/(1.-sqv(k)) - qc1(k)= sqc(k)/(1.-sqv(k)) - dqc1(k)=0.0 - dqi1(k)=0.0 - dqni1(k)=0.0 - dqnc1(k)=0.0 - dqnwfa1(k)=0.0 - dqnifa1(k)=0.0 - dqnbca1(k)=0.0 - dozone1(k)=0.0 - IF(FLAG_QI)THEN - sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) - qi1(k)= sqi(k)/(1.-sqv(k)) - sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - qi1(k)=0.0 - sqi(k)=0.0 - sqw(k)= sqv(k)+sqc(k) - thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - ENDIF - thetav(k)=th1(k)*(1.+0.608*sqv(k)) - thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - - IF (FLAG_QNI ) THEN - qni1(k)=qni(i,k) - ELSE - qni1(k)=0.0 - ENDIF - IF (FLAG_QNC ) THEN - qnc1(k)=qnc(i,k) - ELSE - qnc1(k)=0.0 - ENDIF - IF (FLAG_QNWFA ) THEN - qnwfa1(k)=qnwfa(i,k) - ELSE - qnwfa1(k)=0.0 - ENDIF - IF (FLAG_QNIFA ) THEN - qnifa1(k)=qnifa(i,k) - ELSE - qnifa1(k)=0.0 - ENDIF - IF (FLAG_QNBCA .and. PRESENT(qnbca)) THEN - qnbca1(k)=qnbca(i,k) - ELSE - qnbca1(k)=0.0 - ENDIF - IF (PRESENT(ozone)) THEN - ozone1(k)=ozone(i,k) - ELSE - ozone1(k)=0.0 - ENDIF - el(k) = el_pbl(i,k) - qke1(k)=qke(i,k) - sh(k) =sh3d(i,k) - sm(k) =sm3d(i,k) - tsq1(k)=tsq(i,k) - qsq1(k)=qsq(i,k) - cov1(k)=cov(i,k) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k) - else - rstoch_col(k)=0.0 - endif - - !edmf - edmf_a1(k)=0.0 - edmf_w1(k)=0.0 - edmf_qc1(k)=0.0 - s_aw1(k)=0. - s_awthl1(k)=0. - s_awqt1(k)=0. - s_awqv1(k)=0. - s_awqc1(k)=0. - s_awu1(k)=0. - s_awv1(k)=0. - s_awqke1(k)=0. - s_awqnc1(k)=0. - s_awqni1(k)=0. - s_awqnwfa1(k)=0. - s_awqnifa1(k)=0. - s_awqnbca1(k)=0. - ![EWDD] - edmf_a_dd1(k)=0.0 - edmf_w_dd1(k)=0.0 - edmf_qc_dd1(k)=0.0 - sd_aw1(k)=0. - sd_awthl1(k)=0. - sd_awqt1(k)=0. - sd_awqv1(k)=0. - sd_awqc1(k)=0. - sd_awu1(k)=0. - sd_awv1(k)=0. - sd_awqke1(k)=0. - sub_thl(k)=0. - sub_sqv(k)=0. - sub_u(k)=0. - sub_v(k)=0. - det_thl(k)=0. - det_sqv(k)=0. - det_sqc(k)=0. - det_u(k)=0. - det_v(k)=0. - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1) - ENDIF - ENDDO ! end k - - !initialize smoke/chem arrays (if used): - if ( mix_chem ) then - do ic = 1,ndvel - vd1(ic) = vdep(i,ic) ! dry deposition velocity - enddo - do k = kts,kte - do ic = 1,nchem - chem1(k,ic) = chem3d(i,k,ic) - s_awchem1(k,ic)=0. - enddo - enddo - else - do ic = 1,ndvel - vd1(ic) = 0. ! dry deposition velocity - enddo - do k = kts,kte - do ic = 1,nchem - chem1(k,ic) = 0. - s_awchem1(k,ic)=0. - enddo - enddo - endif - - zw(kte+1)=zw(kte)+dz(i,kte) - !EDMF - s_aw1(kte+1)=0. - s_awthl1(kte+1)=0. - s_awqt1(kte+1)=0. - s_awqv1(kte+1)=0. - s_awqc1(kte+1)=0. - s_awu1(kte+1)=0. - s_awv1(kte+1)=0. - s_awqke1(kte+1)=0. - s_awqnc1(kte+1)=0. - s_awqni1(kte+1)=0. - s_awqnwfa1(kte+1)=0. - s_awqnifa1(kte+1)=0. - s_awqnbca1(kte+1)=0. - sd_aw1(kte+1)=0. - sd_awthl1(kte+1)=0. - sd_awqt1(kte+1)=0. - sd_awqv1(kte+1)=0. - sd_awqc1(kte+1)=0. - sd_awu1(kte+1)=0. - sd_awv1(kte+1)=0. - sd_awqke1(kte+1)=0. - IF ( mix_chem ) THEN - DO ic = 1,nchem - s_awchem1(kte+1,ic)=0. - ENDDO - ENDIF + !Initialize some arrays + if (tke_budget .eq. 1) then + dqke(i,:)=qke(i,:) + endif + if (FLAG_QI ) then + sqi(:)=sqi3D(i,:) + else + sqi = 0.0 + endif + if (FLAG_QS ) then + sqs(:)=sqs3D(i,:) + else + sqs = 0.0 + endif + if (icloud_bl > 0) then + CLDFRA_BL1D(:)=CLDFRA_BL(i,:) + QC_BL1D(:) =QC_BL(i,:) + QI_BL1D(:) =QI_BL(i,:) + cldfra_bl1D_old(:)=cldfra_bl(i,:) + qc_bl1D_old(:)=qc_bl(i,:) + qi_bl1D_old(:)=qi_bl(i,:) + else + CLDFRA_BL1D =0.0 + QC_BL1D =0.0 + QI_BL1D =0.0 + cldfra_bl1D_old=0.0 + qc_bl1D_old =0.0 + qi_bl1D_old =0.0 + endif + dz1(kts:kte) =dz(i,kts:kte) + u1(kts:kte) =u(i,kts:kte) + v1(kts:kte) =v(i,kts:kte) + w1(kts:kte) =w(i,kts:kte) + th1(kts:kte) =th(i,kts:kte) + tk1(kts:kte) =T3D(i,kts:kte) + p1(kts:kte) =p(i,kts:kte) + ex1(kts:kte) =exner(i,kts:kte) + rho1(kts:kte) =rho(i,kts:kte) + sqv(kts:kte) =sqv3D(i,kts:kte) !/(1.+qv(i,kts:kte)) + sqc(kts:kte) =sqc3D(i,kts:kte) !/(1.+qv(i,kts:kte)) + qv1(kts:kte) =sqv(kts:kte)/(1.-sqv(kts:kte)) + qc1(kts:kte) =sqc(kts:kte)/(1.-sqv(kts:kte)) + qi1(kts:kte) =sqi(kts:kte)/(1.-sqv(kts:kte)) + qs1(kts:kte) =sqs(kts:kte)/(1.-sqv(kts:kte)) + dqc1(kts:kte) =0.0 + dqi1(kts:kte) =0.0 + dqs1(kts:kte) =0.0 + dqni1(kts:kte) =0.0 + dqnc1(kts:kte) =0.0 + dqnwfa1(kts:kte)=0.0 + dqnifa1(kts:kte)=0.0 + dqnbca1(kts:kte)=0.0 + dozone1(kts:kte)=0.0 + IF (FLAG_QNI ) THEN + qni1(kts:kte)=qni(i,kts:kte) + ELSE + qni1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNC ) THEN + qnc1(kts:kte)=qnc(i,kts:kte) + ELSE + qnc1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNWFA ) THEN + qnwfa1(kts:kte)=qnwfa(i,kts:kte) + ELSE + qnwfa1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNIFA ) THEN + qnifa1(kts:kte)=qnifa(i,kts:kte) + ELSE + qnifa1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNBCA ) THEN + qnbca1(kts:kte)=qnbca(i,kts:kte) + ELSE + qnbca1(kts:kte)=0.0 + ENDIF + IF (FLAG_OZONE ) THEN + ozone1(kts:kte)=ozone(i,kts:kte) + ELSE + ozone1(kts:kte)=0.0 + ENDIF + el(kts:kte) =el_pbl(i,kts:kte) + qke1(kts:kte)=qke(i,kts:kte) + sh(kts:kte) =sh3d(i,kts:kte) + sm(kts:kte) =sm3d(i,kts:kte) + tsq1(kts:kte)=tsq(i,kts:kte) + qsq1(kts:kte)=qsq(i,kts:kte) + cov1(kts:kte)=cov(i,kts:kte) + if (spp_pbl==1) then + rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte) + else + rstoch_col(kts:kte)=0.0 + endif + !edmf + edmf_a1 =0.0 + edmf_w1 =0.0 + edmf_qc1 =0.0 + s_aw1 =0.0 + s_awthl1 =0.0 + s_awqt1 =0.0 + s_awqv1 =0.0 + s_awqc1 =0.0 + s_awu1 =0.0 + s_awv1 =0.0 + s_awqke1 =0.0 + s_awqnc1 =0.0 + s_awqni1 =0.0 + s_awqnwfa1 =0.0 + s_awqnifa1 =0.0 + s_awqnbca1 =0.0 + ![EWDD] + edmf_a_dd1 =0.0 + edmf_w_dd1 =0.0 + edmf_qc_dd1=0.0 + sd_aw1 =0.0 + sd_awthl1 =0.0 + sd_awqt1 =0.0 + sd_awqv1 =0.0 + sd_awqc1 =0.0 + sd_awu1 =0.0 + sd_awv1 =0.0 + sd_awqke1 =0.0 + sub_thl =0.0 + sub_sqv =0.0 + sub_u =0.0 + sub_v =0.0 + det_thl =0.0 + det_sqv =0.0 + det_sqc =0.0 + det_u =0.0 + det_v =0.0 + + do k = kts,kte + if (k==kts) then + zw(k)=0. + else + zw(k)=zw(k-1)+dz(i,k-1) + endif + !keep snow out for now - increases ceiling bias + sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) + thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*(sqi(k))!+sqs(k)) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + thetav(k)=th1(k)*(1.+p608*sqv(k)) + enddo ! end k + zw(kte+1)=zw(kte)+dz(i,kte) + + !initialize smoke/chem arrays (if used): + if ( mix_chem ) then + do ic = 1,ndvel + vd1(ic) = vdep(i,ic) ! dry deposition velocity + enddo + do k = kts,kte + do ic = 1,nchem + chem1(k,ic) = chem3d(i,k,ic) + enddo + enddo + else + do ic = 1,ndvel + vd1(ic) = 0. ! dry deposition velocity + enddo + do k = kts,kte + do ic = 1,nchem + chem1(k,ic) = 0. + enddo + enddo + endif + s_awchem1(kts:kte+1,1:nchem) = 0.0 -!> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ +!> - Call get_pblh() to calculate the hybrid \f$\theta_{v}-TKE\f$ !! PBL height diagnostic. - CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - & Qke1,zw,dz1,xland(i),KPBL(i)) + CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate the similarity functions, !! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control !! the scale-adaptive behaviour for the local and nonlocal !! components, respectively. - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - ENDIF + if (scaleaware > 0.) then + call SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) + else + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 + endif - sqcg= 0.0 !ill-defined variable; qcg has been removed - cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! -ch(i)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - flqv = qfx(i)/rho1(kts) - flqc = 0.0 !currently no sea-spray fluxes, fog settling hangled elsewhere - th_sfc = ts(i)/ex1(kts) - - ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS - flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux - fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux - - ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) - zet = 0.5*dz(i,kts)*rmol(i) - zet = MAX(zet, -20.) - zet = MIN(zet, 20.) - !if(i.eq.idbg)print*,"updated z/L=",zet - if (bl_mynn_stfunc == 0) then - !Original Kansas-type stability functions - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if + sqcg= 0.0 !ill-defined variable; qcg has been removed + cpm=cp*(1.+0.84*qv1(kts)) + exnerg=(ps(i)/p1000mb)**rcp + + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! -ch(i)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + flqv = qfx(i)/rho1(kts) + flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere + th_sfc = ts(i)/ex1(kts) + + ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS + flq =flqv+flqc !! LATENT + flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux + fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux + + ! Update 1/L using updated sfc heat flux and friction velocity + rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) + zet = 0.5*dz(i,kts)*rmol(i) + zet = MAX(zet, -20.) + zet = MIN(zet, 20.) + !if(i.eq.idbg)print*,"updated z/L=",zet + if (bl_mynn_stfunc == 0) then + !Original Kansas-type stability functions + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet else - !Updated stability functions (Puhales, 2020) - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) end if + else + !Updated stability functions (Puhales, 2020) + phi_m = phim(zet) + pmz = phi_m - zet + phh = phih(zet) + end if !> - Call mym_condensation() to calculate the nonconvective component !! of the subgrid cloud fraction and mixing ratio as well as the functions !! used to calculate the buoyancy flux. Different cloud PDFs can be !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. - CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,xland(i), & - &thl,sqw,sqv,sqc,sqi, & - &p1,ex1,tsq1,qsq1,cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &PBLH(i),HFX(i), & - &Vt, Vq, th1, sgm, rmol(i), & - &spp_pbl, rstoch_col ) + call mym_condensation (kts,kte, & + &dx(i),dz1,zw,xland(i), & + &thl,sqw,sqv,sqc,sqi,sqs, & + &p1,ex1,tsq1,qsq1,cov1, & + &Sh,el,bl_mynn_cloudpdf, & + &qc_bl1D,qi_bl1D,cldfra_bl1D, & + &PBLH(i),HFX(i), & + &Vt, Vq, th1, sgm, rmol(i), & + &spp_pbl, rstoch_col ) !> - Add TKE source driven by cloud top cooling !! Calculate the buoyancy production of TKE from cloud-top cooling when !! \p bl_mynn_topdown =1. - IF (bl_mynn_topdown.eq.1)then - CALL topdown_cloudrad(kts,kte,dz1,zw, & - &xland(i),kpbl(i),PBLH(i), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten(i,:), & - &maxKHtopdown(i),KHtopdown,TKEprodTD ) - ELSE - maxKHtopdown(i) = 0.0 - KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte) = 0.0 - ENDIF + if (bl_mynn_topdown.eq.1) then + call topdown_cloudrad(kts,kte,dz1,zw,fltv, & + &xland(i),kpbl(i),PBLH(i), & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten(i,:), & + &maxKHtopdown(i),KHtopdown,TKEprodTD ) + else + maxKHtopdown(i) = 0.0 + KHtopdown(kts:kte) = 0.0 + TKEprodTD(kts:kte) = 0.0 + endif - IF (bl_mynn_edmf > 0) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i - CALL DMP_mf( & - &kts,kte,delt,zw,dz1,p1,rho1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1,qnbca1, & - &ex1,Vt,Vq,sgm, & - &ust(i),flt,fltv,flq,flqv, & - &PBLH(i),KPBL(i),DX(i), & - &xland(i),th_sfc, & + if (bl_mynn_edmf > 0) then + !PRINT*,"Calling DMP Mass-Flux: i= ",i + call DMP_mf( & + &kts,kte,delt,zw,dz1,p1,rho1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &qnc1,qni1,qnwfa1,qnifa1,qnbca1, & + &ex1,Vt,Vq,sgm, & + &ust(i),flt,fltv,flq,flqv, & + &PBLH(i),KPBL(i),DX(i), & + &xland(i),th_sfc, & ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & + &edmf_a1,edmf_w1,edmf_qt1, & + &edmf_thl1,edmf_ent1,edmf_qc1, & ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & - & s_awqnc1,s_awqni1, & - & s_awqnwfa1,s_awqnifa1,s_awqnbca1,& - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1, & + &s_awu1,s_awv1,s_awqke1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & ! chem/smoke mixing - & nchem,chem1,s_awchem1, & - & mix_chem, & - & qc_bl1D,cldfra_bl1D, & - & qc_bl1D_old,cldfra_bl1D_old, & - & FLAG_QC,FLAG_QI, & - & FLAG_QNC,FLAG_QNI, & - & FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,& - & Psig_shcu(i), & - & nupdraft(i),ktop_plume(i), & - & maxmf(i),ztop_plume, & - & spp_pbl,rstoch_col ) - ENDIF + &nchem,chem1,s_awchem1, & + &mix_chem, & + &qc_bl1D,cldfra_bl1D, & + &qc_bl1D_old,cldfra_bl1D_old, & + &FLAG_QC,FLAG_QI, & + &FLAG_QNC,FLAG_QNI, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &Psig_shcu(i), & + &maxwidth(i),ktop_plume(i), & + &maxmf(i),ztop_plume(i), & + &spp_pbl,rstoch_col ) + endif - IF (bl_mynn_edmf_dd == 1) THEN - CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & - &u1,v1,th1,thl,thetav,tk1, & - sqw,sqv,sqc,rho1,ex1, & - &ust(i),flt,flq, & - &PBLH(i),KPBL(i), & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & - &edmf_thl_dd1,edmf_ent_dd1, & - &edmf_qc_dd1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & - &sd_awqke1, & - &qc_bl1d,cldfra_bl1d, & - &rthraten(i,:) ) - ENDIF + if (bl_mynn_edmf_dd == 1) then + call DDMF_JPL(kts,kte,delt,zw,dz1,p1, & + &u1,v1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,rho1,ex1, & + &ust(i),flt,flq, & + &PBLH(i),KPBL(i), & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & + &edmf_thl_dd1,edmf_ent_dd1, & + &edmf_qc_dd1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & + &sd_awqke1, & + &qc_bl1d,cldfra_bl1d, & + &rthraten(i,:) ) + endif - !Capability to substep the eddy-diffusivity portion - !do nsub = 1,2 - delt2 = delt !*0.5 !only works if topdown=0 - - CALL mym_turbulence ( & - &kts,kte,xland(i),closure, & - &dz1, DX(i), zw, & - &u1, v1, thl, thetav, sqc, sqw, & - &thlsg, sqwsg, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i), flt, flq, & - &PBLH(i),th1, & - &Sh,Sm,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &tke_budget, & - &Psig_bl(i),Psig_shcu(i), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1, & - &TKEprodTD, & - &spp_pbl,rstoch_col) + !Capability to substep the eddy-diffusivity portion + !do nsub = 1,2 + delt2 = delt !*0.5 !only works if topdown=0 + + call mym_turbulence( & + &kts,kte,xland(i),closure, & + &dz1, DX(i), zw, & + &u1, v1, thl, thetav, sqc, sqw, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i), flt, fltv, flq, & + &PBLH(i),th1, & + &Sh,Sm,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &tke_budget, & + &Psig_bl(i),Psig_shcu(i), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_w1,edmf_a1, & + &TKEprodTD, & + &spp_pbl,rstoch_col ) !> - Call mym_predict() to solve TKE and !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ !! for the following time step. - CALL mym_predict (kts,kte,closure, & - &delt2, dz1, & - &ust(i), flt, flq, pmz, phh, & - &el, dfq, rho1, pdk, pdt, pdq, pdc,& - &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke,& - &qWT1, qDISS1,tke_budget ) !! TKE budget (Puhales, 2020) - - if (dheat_opt > 0) then - DO k=kts,kte-1 - ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - ! Limit heating above 100 mb: - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) - ENDDO - diss_heat(kte) = 0. - else - diss_heat(1:kte) = 0. - endif + call mym_predict(kts,kte,closure, & + &delt2, dz1, & + &ust(i), flt, flq, pmz, phh, & + &el, dfq, rho1, pdk, pdt, pdq, pdc, & + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke, & + &qWT1, qDISS1, tke_budget ) + + if (dheat_opt > 0) then + do k=kts,kte-1 + ! Set max dissipative heating rate to 7.2 K per hour + diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + ! Limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + enddo + diss_heat(kte) = 0. + else + diss_heat(1:kte) = 0. + endif !> - Call mynn_tendencies() to solve for tendencies of !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. - CALL mynn_tendencies(kts,kte,i, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qnc1, qni1, & - &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, sqw, & - &qnwfa1, qnifa1, qnbca1, ozone1, & - &ust(i),flt,flq,flqv,flqc, & - &wspd(i),uoce(i),voce(i), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, Dqnbca1, & - &Dozone1, & - &diss_heat, & + call mynn_tendencies(kts,kte,i, & + &delt, dz1, rho1, & + &u1, v1, th1, tk1, qv1, & + &qc1, qi1, kzero, qnc1, qni1, & !kzero replaces qs1 - not mixing snow + &ps(i), p1, ex1, thl, & + &sqv, sqc, sqi, kzero, sqw, & !kzero replaces sqs - not mixing snow + &qnwfa1, qnifa1, qnbca1, ozone1, & + &ust(i),flt,flq,flqv,flqc, & + &wspd(i),uoce(i),voce(i), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqs1, Dqnc1, Dqni1, & + &Dqnwfa1, Dqnifa1, Dqnbca1, & + &Dozone1, & + &diss_heat, & ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1,s_awqnbca1,& - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1, & - sd_awu1,sd_awv1, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_QNBCA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - - - IF ( mix_chem ) THEN - IF ( rrfs_sd ) THEN - CALL mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &emis_ant_no(i), & - &frp(i), rrfs_sd, & - &enh_mix, smoke_dbg ) - ELSE - CALL mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &zero, & - &zero, rrfs_sd, & - &enh_mix, smoke_dbg ) - ENDIF - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) - ENDDO - ENDDO - ENDIF + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1, & + &sd_awu1,sd_awv1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_QNBCA,FLAG_OZONE, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + + + if ( mix_chem ) then + if ( rrfs_sd ) then + call mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &emis_ant_no(i), & + &frp(i), rrfs_sd, & + &enh_mix, smoke_dbg ) + else + call mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + endif + do ic = 1,nchem + do k = kts,kte + chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) + enddo + enddo + endif - CALL retrieve_exchange_coeffs(kts,kte,& - &dfm, dfh, dz1, K_m1, K_h1) - - !UPDATE 3D ARRAYS - do k=kts,kte - exch_m(i,k)=K_m1(k) - exch_h(i,k)=K_h1(k) - rublten(i,k)=du1(k) - rvblten(i,k)=dv1(k) - rthblten(i,k)=dth1(k) - rqvblten(i,k)=dqv1(k) - if (bl_mynn_cloudmix > 0) then - if (present(sqc3D) .and. flag_qc) rqcblten(i,k)=dqc1(k) - if (present(sqi3D) .and. flag_qi) rqiblten(i,k)=dqi1(k) - else - if (present(sqc3D) .and. flag_qc) rqcblten(i,k)=0. - if (present(sqi3D) .and. flag_qi) rqiblten(i,k)=0. - endif - if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then - if (present(qnc) .and. flag_qnc) rqncblten(i,k)=dqnc1(k) - if (present(qni) .and. flag_qni) rqniblten(i,k)=dqni1(k) - if (present(qnwfa) .and. flag_qnwfa) rqnwfablten(i,k)=dqnwfa1(k) - if (present(qnifa) .and. flag_qnifa) rqnifablten(i,k)=dqnifa1(k) - if (present(qnbca) .and. flag_qnbca) rqnbcablten(i,k)=dqnbca1(k) - else - if (present(qnc) .and. flag_qnc) rqncblten(i,k)=0. - if (present(qni) .and. flag_qni) rqniblten(i,k)=0. - if (present(qnwfa) .and. flag_qnwfa) rqnwfablten(i,k)=0. - if (present(qnifa) .and. flag_qnifa) rqnifablten(i,k)=0. - if (present(qnbca) .and. flag_qnbca) rqnbcablten(i,k)=0. - endif - dozone(i,k)=dozone1(k) - - if (icloud_bl > 0) then - qc_bl(i,k)=qc_bl1D(k) - qi_bl(i,k)=qi_bl1D(k) - cldfra_bl(i,k)=cldfra_bl1D(k) - endif - - el_pbl(i,k)=el(k) - qke(i,k)=qke1(k) - tsq(i,k)=tsq1(k) - qsq(i,k)=qsq1(k) - cov(i,k)=cov1(k) - sh3d(i,k)=sh(k) - sm3d(i,k)=sm(k) - enddo !end-k + call retrieve_exchange_coeffs(kts,kte, & + &dfm, dfh, dz1, K_m1, K_h1 ) + + !UPDATE 3D ARRAYS + exch_m(i,kts:kte) =k_m1(kts:kte) + exch_h(i,kts:kte) =k_h1(kts:kte) + rublten(i,kts:kte) =du1(kts:kte) + rvblten(i,kts:kte) =dv1(kts:kte) + rthblten(i,kts:kte)=dth1(kts:kte) + rqvblten(i,kts:kte)=dqv1(kts:kte) + if (bl_mynn_cloudmix > 0) then + if (flag_qc) rqcblten(i,kts:kte)=dqc1(kts:kte) + if (flag_qi) rqiblten(i,kts:kte)=dqi1(kts:kte) + if (flag_qs) rqsblten(i,kts:kte)=dqs1(kts:kte) + else + if (flag_qc) rqcblten(i,:)=0. + if (flag_qi) rqiblten(i,:)=0. + if (flag_qs) rqsblten(i,:)=0. + endif + if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then + if (flag_qnc) rqncblten(i,kts:kte) =dqnc1(kts:kte) + if (flag_qni) rqniblten(i,kts:kte) =dqni1(kts:kte) + if (flag_qnwfa) rqnwfablten(i,kts:kte)=dqnwfa1(kts:kte) + if (flag_qnifa) rqnifablten(i,kts:kte)=dqnifa1(kts:kte) + if (flag_qnbca) rqnbcablten(i,kts:kte)=dqnbca1(kts:kte) + else + if (flag_qnc) rqncblten(i,:) =0. + if (flag_qni) rqniblten(i,:) =0. + if (flag_qnwfa) rqnwfablten(i,:)=0. + if (flag_qnifa) rqnifablten(i,:)=0. + if (flag_qnbca) rqnbcablten(i,:)=0. + endif + dozone(i,kts:kte)=dozone1(kts:kte) + if (icloud_bl > 0) then + qc_bl(i,kts:kte) =qc_bl1D(kts:kte) + qi_bl(i,kts:kte) =qi_bl1D(kts:kte) + cldfra_bl(i,kts:kte)=cldfra_bl1D(kts:kte) + endif + el_pbl(i,kts:kte)=el(kts:kte) + qke(i,kts:kte) =qke1(kts:kte) + tsq(i,kts:kte) =tsq1(kts:kte) + qsq(i,kts:kte) =qsq1(kts:kte) + cov(i,kts:kte) =cov1(kts:kte) + sh3d(i,kts:kte) =sh(kts:kte) + sm3d(i,kts:kte) =sm(kts:kte) + + if (tke_budget .eq. 1) then + !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) + !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) + k=kts + qSHEAR1(k) =4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered + qBUOY1(k) =4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered + !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array + do k = kts,kte-1 + qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z + qBUOY(i,k) =0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z + qWT(i,k) =qWT1(k) + qDISS(i,k) =qDISS1(k) + dqke(i,k) =(qke1(k)-dqke(i,k))*0.5/delt + enddo + !! Upper boundary conditions + k=kte + qSHEAR(i,k) =0. + qBUOY(i,k) =0. + qWT(i,k) =0. + qDISS(i,k) =0. + dqke(i,k) =0. + endif - if (tke_budget .eq. 1) then - !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) - !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) - k=kts - qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered - qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered - !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - do k = kts,kte-1 - qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z - qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z - qWT(i,k)=qWT1(k) - qDISS(i,k)=qDISS1(k) - dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt - enddo - !! Upper boundary conditions - k=kte - qSHEAR(i,k)=0. - qBUOY(i,k)=0. - qWT(i,k)=0. - qDISS(i,k)=0. - dqke(i,k)=0. + !update updraft/downdraft properties + if (bl_mynn_output > 0) then !research mode == 1 + if (bl_mynn_edmf > 0) then + edmf_a(i,kts:kte) =edmf_a1(kts:kte) + edmf_w(i,kts:kte) =edmf_w1(kts:kte) + edmf_qt(i,kts:kte) =edmf_qt1(kts:kte) + edmf_thl(i,kts:kte) =edmf_thl1(kts:kte) + edmf_ent(i,kts:kte) =edmf_ent1(kts:kte) + edmf_qc(i,kts:kte) =edmf_qc1(kts:kte) + sub_thl3D(i,kts:kte)=sub_thl(kts:kte) + sub_sqv3D(i,kts:kte)=sub_sqv(kts:kte) + det_thl3D(i,kts:kte)=det_thl(kts:kte) + det_sqv3D(i,kts:kte)=det_sqv(kts:kte) endif + !if (bl_mynn_edmf_dd > 0) THEN + ! edmf_a_dd(i,kts:kte) =edmf_a_dd1(kts:kte) + ! edmf_w_dd(i,kts:kte) =edmf_w_dd1(kts:kte) + ! edmf_qt_dd(i,kts:kte) =edmf_qt_dd1(kts:kte) + ! edmf_thl_dd(i,kts:kte)=edmf_thl_dd1(kts:kte) + ! edmf_ent_dd(i,kts:kte)=edmf_ent_dd1(kts:kte) + ! edmf_qc_dd(i,kts:kte) =edmf_qc_dd1(kts:kte) + !endif + endif - !update updraft/downdraft properties - if (bl_mynn_output > 0) THEN !research mode == 1 - if (bl_mynn_edmf > 0) THEN - DO k = kts,kte - edmf_a(i,k)=edmf_a1(k) - edmf_w(i,k)=edmf_w1(k) - edmf_qt(i,k)=edmf_qt1(k) - edmf_thl(i,k)=edmf_thl1(k) - edmf_ent(i,k)=edmf_ent1(k) - edmf_qc(i,k)=edmf_qc1(k) - sub_thl3D(i,k)=sub_thl(k) - sub_sqv3D(i,k)=sub_sqv(k) - det_thl3D(i,k)=det_thl(k) - det_sqv3D(i,k)=det_sqv(k) - ENDDO - endif -! if (bl_mynn_edmf_dd > 0) THEN -! DO k = kts,kte -! edmf_a_dd(i,k)=edmf_a_dd1(k) -! edmf_w_dd(i,k)=edmf_w_dd1(k) -! edmf_qt_dd(i,k)=edmf_qt_dd1(k) -! edmf_thl_dd(i,k)=edmf_thl_dd1(k) -! edmf_ent_dd(i,k)=edmf_ent_dd1(k) -! edmf_qc_dd(i,k)=edmf_qc_dd1(k) -! ENDDO -! ENDIF - ENDIF - - !*** Begin debug prints - IF ( debug_code .and. (i .eq. idbg)) THEN - IF ( ABS(QFX(i))>.001)print*,& - "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) - IF ( ABS(HFX(i))>1100.)print*,& - "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) - DO k = kts,kte - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 2.0 )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 7000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) - IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) - IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) - IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) - IF (icloud_bl > 0) then - IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) - ENDIF - ENDIF - - !IF (I==IMD .AND. J==JMD) THEN - ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) - ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) - ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) - ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) - ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) - ! PRINT*," vq=",vq(k)," vt=",vt(k) - !ENDIF - ENDDO !end-k - ENDIF - !*** End debug prints + !*** Begin debug prints + if ( debug_code .and. (i .eq. idbg)) THEN + if ( ABS(QFX(i))>.001)print*,& + "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) + if ( ABS(HFX(i))>1100.)print*,& + "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) + do k = kts,kte + IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) + IF ( ABS(vt(k)) > 2.0 )print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) + IF ( ABS(vq(k)) > 7000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) + IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) + IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) + IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) + IF (icloud_bl > 0) then + IF ( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) + ENDIF + ENDIF - !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) = 0.5*MAX(qke(i,kts),1.0e-10) - !DO k = kts+1,kte - ! afk = dz1(k)/( dz1(k)+dz1(k-1) ) - ! abk = 1.0 -afk - ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3) - !ENDDO + !IF (I==IMD .AND. J==JMD) THEN + ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) + ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) + ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) + ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) + ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) + ! PRINT*," vq=",vq(k)," vt=",vt(k) + !ENDIF + enddo !end-k + endif - ENDDO !end i-loop + enddo !end i-loop !ACF copy qke into qke_adv if using advection IF (bl_mynn_tkeadvect) THEN @@ -1602,7 +1515,6 @@ SUBROUTINE mym_initialize ( & & kts,kte,xland, & & dz, dx, zw, & & u, v, thl, qw, & - & thlsg, qwsg, & ! & ust, rmo, pmz, phh, flt, flq, & & zi, theta, thetav, sh, sm, & & ust, rmo, el, & @@ -1613,28 +1525,28 @@ SUBROUTINE mym_initialize ( & & spp_pbl,rstoch_col) ! !------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: bl_mynn_mixlength - LOGICAL, INTENT(IN) :: INITIALIZE_QKE -! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx, xland - 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,cldfra_bl1D,& - edmf_w1,edmf_a1 - 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 - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg - REAL, DIMENSION(kts:kte) :: rstoch_col - INTEGER ::spp_pbl + integer, intent(in) :: kts,kte + integer, intent(in) :: bl_mynn_mixlength + logical, intent(in) :: INITIALIZE_QKE +! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq + real(kind_phys), intent(in) :: rmo, Psig_bl, xland + real(kind_phys), intent(in) :: dx, ust, zi + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,& + &qw,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov + real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke + real(kind_phys), dimension(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & + &gm,gh,sm,sh,qkw,vt,vq + integer :: k,l,lmax + real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & + &flt=0.,fltv=0.,flq=0.,tmpq + real(kind_phys), dimension(kts:kte) :: theta,thetav + real(kind_phys), dimension(kts:kte) :: rstoch_col + integer ::spp_pbl !> - At first ql, vt and vq are set to zero. DO k = kts,kte @@ -1647,7 +1559,6 @@ SUBROUTINE mym_initialize ( & CALL mym_level2 ( kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1689,7 +1600,7 @@ SUBROUTINE mym_initialize ( & CALL mym_length ( & & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u, v, qke, & & dtv, & @@ -1807,31 +1718,31 @@ END SUBROUTINE mym_initialize SUBROUTINE mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& - thetav,thlsg,qwsg - REAL, DIMENSION(kts:kte), INTENT(out) :: & + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte), intent(in) :: u,v, & + &thl,qw,ql,vt,vq,thetav + real(kind_phys), dimension(kts:kte), intent(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh - INTEGER :: k + 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 + real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, & + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, & + &afk,abk,ri,rf - REAL :: a2fac + real(kind_phys):: a2fac ! ev = 2.5e6 ! tv0 = 0.61*tref @@ -1859,11 +1770,7 @@ SUBROUTINE mym_level2 (kts,kte, & duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 duz = duz /dzk**2 dtz = ( thl(k)-thl(k-1) )/( dzk ) - !Alternatively, use SGS clouds for thl - !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk ) dqz = ( qw(k)-qw(k-1) )/( dzk ) - !Alternatively, use SGS clouds for qw - !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk ) ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q @@ -1942,7 +1849,7 @@ END SUBROUTINE mym_level2 SUBROUTINE mym_length ( & & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u1, v1, qke, & & dtv, & @@ -1954,58 +1861,57 @@ SUBROUTINE mym_length ( & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx,xland - REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& - edmf_w1,edmf_a1 - REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el - REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - - REAL :: elt,vsc - - REAL, DIMENSION(kts:kte), INTENT(IN) :: theta - REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + integer, intent(in) :: bl_mynn_mixlength + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland + real(kind_phys), intent(in) :: dx,zi + real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, & + &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el + real(kind_phys), dimension(kts:kte), intent(in) :: dtv + real(kind_phys):: elt,vsc + real(kind_phys), dimension(kts:kte), intent(in) :: theta + real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: - REAL :: cns, & !< for surface layer (els) in stable conditions - alp1, & !< for turbulent length scale (elt) - alp2, & !< for buoyancy length scale (elb) - alp3, & !< for buoyancy enhancement factor of elb - alp4, & !< for surface layer (els) in unstable conditions - alp5, & !< for BouLac mixing length or above PBLH - alp6 !< for mass-flux/ + real(kind_phys):: cns, & !< for surface layer (els) in stable conditions + alp1, & !< for turbulent length scale (elt) + alp2, & !< for buoyancy length scale (elb) + alp3, & !< for buoyancy enhancement factor of elb + alp4, & !< for surface layer (els) in unstable conditions + alp5, & !< for BouLac mixing length or above PBLH + alp6 !< for mass-flux/ !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - REAL, PARAMETER :: minzi = 300. !< min mixed-layer height - REAL, PARAMETER :: maxdz = 750. !< max (half) transition layer depth + real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height + real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth !! =0.3*2500 m PBLH, so the transition !! layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth + real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) - REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) - + real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m) + real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1) + real(kind_phys), parameter :: qke_elb_min = 0.018 - INTEGER :: i,j,k - REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & - & elf,el_stab,el_mf,el_stab_mf,elb_mf, & + integer :: i,j,k + real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & + & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les - REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud + real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref ! gtr = 9.81/tref @@ -2027,11 +1933,11 @@ SUBROUTINE mym_length ( & h1=MIN(h1,maxdz) ! 1/2 transition layer depth h2=h1/2.0 ! 1/4 transition layer depth - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + qkw(kts) = SQRT(MAX(qke(kts), qkemin)) 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)) + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin)) END DO elt = 1.0e-5 @@ -2051,7 +1957,7 @@ SUBROUTINE mym_length ( & 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) + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,k=1) is not zero. ** el(kts) = 0.0 @@ -2096,28 +2002,28 @@ SUBROUTINE mym_length ( & uonset= 15. wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) cns = 3.5 - alp1 = 0.22 !was 0.21 - alp2 = 0.25 !was 0.3 - alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls + alp1 = 0.23 + alp2 = 0.3 + alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,200.) !minzi) - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth + zi2 = MAX(zi,300.) !minzi) + h1 = MAX(0.3*zi2,300.) + h1 = MIN(h1,600.) ! 1/2 transition layer depth + h2 = h1/2.0 ! 1/4 transition layer depth - qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + qtke(kts) = MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels + thetaw(kts) = theta(kts) !theta at full-sigma levels + qkw(kts) = SQRT(MAX(qke(kts), qkemin)) DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - qtke(k) = 0.5*(qkw(k)**2) ! q -> TKE + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin)) + qtke(k) = max(0.5*(qkw(k)**2), 0.005) ! q -> TKE thetaw(k)= theta(k)*abk + theta(k-1)*afk END DO @@ -2129,17 +2035,17 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. zi2+h1) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk + qdz = min(max( qkw(k)-qmin, 0.01 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 zwk = zw(k) END DO - elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) + elt = MIN( MAX( alp1*elt/vsc, 8.), 400.) !avoid use of buoyancy flux functions which are ill-defined at the surface !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq - vflx = flt + vflx = fltv vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** @@ -2154,12 +2060,12 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - bv = max( sqrt( gtr*dtv(k) ), 0.001) - elb = MAX(alp2*qkw(k), & + bv = max( sqrt( gtr*dtv(k) ), 0.0001) + elb = MAX(alp2*max(qkw(k), qke_elb_min), & & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) - elf = 0.65 * qkw(k)/bv + elf = 1.0 * max(qkw(k), qke_elb_min)/bv elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 @@ -2179,9 +2085,11 @@ SUBROUTINE mym_length ( & !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - !try squared-blending - el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) - el(k) = MIN (el(k), elf) + !try squared-blending - but take out elb (makes it underdiffusive) + !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + el(k) = sqrt( els**2/(1. + (els**2/elt**2))) + el(k) = min(el(k), elb) + el(k) = min(el(k), elf) el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt ! include scale-awareness, except for original MYNN @@ -2194,29 +2102,29 @@ SUBROUTINE mym_length ( & Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.22 !0.21 - alp2 = 0.25 !0.30 - alp3 = 2.0 !1.5 + alp1 = 0.22 + alp2 = 0.30 + alp3 = 2.0 alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length ! Impose limits on the height integration for elt and the transition layer depth !zi2=MAX(zi,minzi) - zi2=MAX(zi, 200.) + zi2=MAX(zi, 300.) !h1=MAX(0.3*zi2,mindz) !h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) h2=h1*0.5 ! 1/4 transition layer depth - qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels - qkw(kts) = SQRT(MAX(qke(kts),1.0e-4)) + qtke(kts)=MAX(0.5*qke(kts), 0.5*qkemin) !tke at full sigma levels + qkw(kts) = SQRT(MAX(qke(kts), qkemin)) 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)) + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk, qkemin)) qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE END DO @@ -2239,7 +2147,7 @@ SUBROUTINE mym_length ( & elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) !avoid use of buoyancy flux functions which are ill-defined at the surface !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vflx = flt + vflx = fltv vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** @@ -2365,15 +2273,15 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) ! lb2 = the average of the length up and length down !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: k,kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + integer, intent(in) :: k,kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), intent(out) :: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw !LOCAL VARS - INTEGER :: izz, found - REAL :: dlu,dld - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + integer :: izz, found + real(kind_phys):: dlu,dld + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !---------------------------------- @@ -2515,16 +2423,16 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) ! 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 + integer, intent(in) :: kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw !LOCAL VARS - INTEGER :: iz, izz, found - REAL, DIMENSION(kts:kte) :: dlu,dld - REAL, PARAMETER :: Lmax=2000. !soft limit - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + integer :: iz, izz, found + real(kind_phys), dimension(kts:kte) :: dlu,dld + real(kind_phys), parameter :: Lmax=2000. !soft limit + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !print*,"IN MYNN-BouLac",kts, kte @@ -2712,10 +2620,9 @@ SUBROUTINE mym_turbulence ( & & xland,closure, & & dz, dx, zw, & & u, v, thl, thetav, ql, qw, & - & thlsg, qwsg, & & qke, tsq, qsq, cov, & & vt, vq, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & zi,theta, & & sh, sm, & & El, & @@ -2726,49 +2633,49 @@ SUBROUTINE mym_turbulence ( & & bl_mynn_mixlength, & & edmf_w1,edmf_a1, & & TKEprodTD, & - & spp_pbl,rstoch_col) + & spp_pbl,rstoch_col ) !------------------------------------------------------------------- -! - INTEGER, INTENT(IN) :: kts,kte + + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget - REAL, INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx,xland,zi - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,& - &TKEprodTD,thlsg,qwsg - - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& + integer, intent(in) :: bl_mynn_mixlength,tke_budget + real(kind_phys), intent(in) :: closure + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq, & + &Psig_bl,Psig_shcu,xland,dx,zi + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, & + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & + &TKEprodTD + + real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, & &pdk,pdt,pdq,pdc,tcd,qcd,el - REAL, DIMENSION(kts:kte), INTENT(inout) :: & + real(kind_phys), dimension(kts:kte), intent(inout) :: & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz,& - upwp,vpwp,Tpwp + real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new + real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + real(kind_phys), 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,& + integer :: k +! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c + real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: cldavg - REAL, DIMENSION(kts:kte), INTENT(in) :: theta + real(kind_phys):: cldavg + real(kind_phys), dimension(kts:kte), intent(in) :: theta - REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod + real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& + real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel @@ -2776,11 +2683,10 @@ SUBROUTINE mym_turbulence ( & DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum, Prlim - REAL, PARAMETER :: Prlimit = 5.0 - + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col + real(kind_phys):: Prnum, shb + real(kind_phys), parameter :: Prlimit = 5.0 ! ! tv0 = 0.61*tref @@ -2798,14 +2704,13 @@ SUBROUTINE mym_turbulence ( & CALL mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! CALL mym_length ( & & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u, v, qke, & & dtv, & @@ -2985,7 +2890,8 @@ SUBROUTINE mym_turbulence ( & !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit !sm(k) = MIN(sm(k), Prlim*Sh(k)) !Pending more testing, keep same Pr limit in sfc layer - sm(k) = MIN(sm(k), Prlimit*Sh(k)) + shb = max(sh(k), 0.02) + sm(k) = MIN(sm(k), Prlimit*shb) ! ** Level 3 : start ** IF ( closure .GE. 3.0 ) THEN @@ -3155,7 +3061,7 @@ SUBROUTINE mym_turbulence ( & ! q-variance (pdq), and covariance (pdc) pdk(k) = elq*( sm(k)*gm(k) & & +sh(k)*gh(k)+gamv ) + & - & TKEprodTD(k) + & 0.5*TKEprodTD(k) ! xmchen pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) pdc(k) = elh*( sh(k)*dtl(k)+gamt ) & @@ -3199,9 +3105,9 @@ SUBROUTINE mym_turbulence ( & !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE !! Buoyncy term takes the TKEprodTD(k) production now - qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+TKEprodTD(k) !staggered + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen - !!!Dissipation Term (now it evaluated on mym_predict) + !!!Dissipation Term (now it evaluated in mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE !! >> EOB @@ -3226,8 +3132,6 @@ SUBROUTINE mym_turbulence ( & qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) END DO ! - - if (spp_pbl==1) then DO k = kts,kte dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) @@ -3294,43 +3198,43 @@ SUBROUTINE mym_predict (kts,kte, & & delt, & & dz, & & ust, flt, flq, pmz, phh, & - & el, dfq, rho, & + & el, dfq, rho, & & pdk, pdt, pdq, pdc, & & qke, tsq, qsq, cov, & & s_aw,s_awqke,bl_mynn_edmf_tke, & & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + integer, intent(in) :: kts,kte #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: closure - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke, tke_budget - REAL, INTENT(IN) :: delt - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho - 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 + real(kind_phys), intent(in) :: closure + integer, intent(in) :: bl_mynn_edmf_tke,tke_budget + real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho + real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc + real(kind_phys), intent(in) :: flt, flq, pmz, phh + real(kind_phys), intent(in) :: ust, delt + real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov ! WA 8/3/15 - REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - REAL, DIMENSION(kts:kte) :: tke_up,dzinv + real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D + real(kind_phys), dimension(kts:kte) :: tke_up,dzinv !! >> EOB - INTEGER :: k - REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x + integer :: k + real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q + real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) IF (bl_mynn_edmf_tke == 0) THEN @@ -3376,7 +3280,7 @@ SUBROUTINE mym_predict (kts,kte, & kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO -!JOE-end conservation mods + !end conservation mods pdk1 = 2.0*ust**3*pmz/( vkz ) phm = 2.0/ust *phh/( vkz ) @@ -3384,8 +3288,8 @@ SUBROUTINE mym_predict (kts,kte, & 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) +! ** pdk(1)+pdk(2) corresponds to pdk1. ** + pdk(kts) = pdk1 - pdk(kts+1) !! pdt(kts) = pdt1 -pdt(kts+1) !! pdq(kts) = pdq1 -pdq(kts+1) @@ -3453,8 +3357,8 @@ SUBROUTINE mym_predict (kts,kte, & CALL tridiag2(kte,a,b,c,d,x) DO k=kts,kte -! qke(k)=max(d(k-kts+1), 1.e-4) - qke(k)=max(x(k), 1.e-4) +! qke(k)=max(d(k-kts+1), qkemin) + qke(k)=max(x(k), qkemin) qke(k)=min(qke(k), 150.) ENDDO @@ -3480,7 +3384,7 @@ SUBROUTINE mym_predict (kts,kte, & ENDDO k=kte qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & - & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggared + & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered !! >> EOBvt qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered END IF @@ -3697,7 +3601,7 @@ END SUBROUTINE mym_predict !! use of the namelist parameter \p bl_mynn_cloudpdf . SUBROUTINE mym_condensation (kts,kte, & & dx, dz, zw, xland, & - & thl, qw, qv, qc, qi, & + & thl, qw, qv, qc, qi, qs, & & p,exner, & & tsq, qsq, cov, & & Sh, el, bl_mynn_cloudpdf, & @@ -3709,50 +3613,56 @@ SUBROUTINE mym_condensation (kts,kte, & !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + integer, intent(in) :: kts,kte, bl_mynn_cloudpdf #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo,xland - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & - &tsq, qsq, cov, th + real(kind_phys), intent(in) :: HFX1,rmo,xland + real(kind_phys), intent(in) :: dx,pblh1 + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, & + &qv,qc,qi,qs,tsq,qsq,cov,th - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm - REAL, DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & - cldfra_bl1D + real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH + real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq - REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& - &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &qmq,qsat_tk - INTEGER :: i,j,k + real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & + &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & + &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc + real(kind_phys), parameter :: qpct_sfc=0.025 + real(kind_phys), parameter :: qpct_pbl=0.030 + real(kind_phys), parameter :: qpct_trp=0.040 + real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 + real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 + integer :: i,j,k - REAL :: erf + real(kind_phys):: erf !VARIABLES FOR ALTERNATIVE SIGMA - REAL::dth,dtl,dqw,dzk,els - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + real:: dth,dtl,dqw,dzk,els + real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el !variables for SGS BL clouds - REAL :: zagl,damp,PBLH2 - REAL :: cfmax + real(kind_phys) :: zagl,damp,PBLH2 + real(kind_phys) :: cfmax !JAYMES: variables for tropopause-height estimation - REAL :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo + real(kind_phys) :: theta1, theta2, ht1, ht2 + integer :: k_tropo ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: qw_pert + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col + real(kind_phys) :: qw_pert ! First, obtain an estimate for the tropopause height (k), using the method employed in the ! Thompson subgrid-cloud scheme. This height will be a consideration later when determining @@ -3828,9 +3738,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = liq_frac*ql(k) qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3888,9 +3795,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = liq_frac*ql(k) qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3911,43 +3815,76 @@ SUBROUTINE mym_condensation (kts,kte, & !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS !but with use of higher-order moments to estimate sigma - PBLH2=MAX(10.,PBLH1) + pblh2=MAX(10._kind_phys,pblh1) zagl = 0. + dzm1 = 0. DO k = kts,kte-1 - zagl = zagl + dz(k) - t = th(k)*exner(k) + zagl = zagl + 0.5*(dz(k) + dzm1) + dzm1 = dz(k) - xl = xl_blend(t) ! obtain latent heat - qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001) + t = th(k)*exner(k) + xl = xl_blend(t) ! obtain latent heat + qsat_tk= qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p + rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys) !dqw/dT: Clausius-Clapeyron - dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) alp(k) = 1.0/( 1.0+dqsl*xlvcp ) bet(k) = dqsl*exner(k) - rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) + rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) ! CB02, Eqn. 4 - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - b(k) = a(k)*rsl ! CB02 variable "b" + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" !SPP - qw_pert = qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) !This form of qmq (the numerator of Q1) no longer uses the a(k) factor qmq = qw_pert - qsat_tk ! saturation deficit/excess; !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) !except neglect all but the first term for sig_r - r3sq = MAX( qsq(k), 0.0 ) + r3sq = max( qsq(k), 0.0 ) !Calculate sigma using higher-order moments: sgm(k) = SQRT( r3sq ) - !Set limits on sigma relative to saturation water vapor - sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tk*0.035 ) !Note: 0.02 results in SWDOWN similar - !to the first-order version of sigma - q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + !Set constraints on sigma relative to saturation water vapor + sgm(k) = min( sgm(k), qsat_tk*0.666 ) + !sgm(k) = max( sgm(k), qsat_tk*0.035 ) + + !introduce vertical grid spacing dependence on min sgm + wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m + sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz + + !allow min sgm to vary with dz and z. + qpct = qpct_pbl*wt + qpct_trp*(1.0-wt) + qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) ) + sgm(k) = max( sgm(k), qsat_tk*qpct ) + + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !Add condition for falling/settling into low-RH layers, so at least + !some cloud fraction is applied for all qc, qs, and qi. + rh_hack= rh(k) + wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) + !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) + if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) + if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + q1k = q1(k) ! backup Q1 for later modification ! Specify cloud fraction @@ -3956,61 +3893,41 @@ SUBROUTINE mym_condensation (kts,kte, & !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) !Best compromise: Improves marine stratus without adding much cold bias. - cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) + cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 ! The cloud water formulations are taken from CB02, Eq. 8. - IF (q1k < 0.) THEN !unsaturated - ql_water = sgm(k)*EXP(1.2*q1k-1) - ql_ice = sgm(k)*EXP(1.2*q1k-1.) - ELSE IF (q1k > 2.) THEN !supersaturated - ql_water = sgm(k)*q1k - ql_ice = sgm(k)*q1k - ELSE !slightly saturated (0 > q1 < 2) - ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ENDIF + maxqc = max(qw(k) - qsat_tk, 0.0) + if (q1k < 0.) then !unsaturated + ql_water = sgm(k)*exp(1.2*q1k-1.) + ql_ice = sgm(k)*exp(1.2*q1k-1.) + elseif (q1k > 2.) then !supersaturated + ql_water = min(sgm(k)*q1k, maxqc) + ql_ice = sgm(k)*q1k + else !slightly saturated (0 > q1 < 2) + ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc) + ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2) + endif !In saturated grid cells, use average of SGS and resolved values - if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) - !since ql_ice is actually the total frozen condensate (snow+ice), - !do not average with grid-scale ice alone - !if ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) + !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) + !ql_ice is actually the total frozen condensate (snow+ice), + !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) ) - if (cldfra_bl1D(k) < 0.01) then + if (cldfra_bl1D(k) < 0.001) then ql_ice = 0.0 ql_water = 0.0 cldfra_bl1D(k) = 0.0 endif - !PHASE PARTITIONING: currently commented out since we are moving towards prognostic sgs clouds - !Make some inferences about the relative amounts of - !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, - !use a simple temperature-dependent partitioning. - ! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning - ! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid - ! liq_frac = 1.0 - ! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice - ! liq_frac = 0.0 - ! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably - ! ! large amounts; assume subgrid follows - ! ! same partioning - ! liq_frac = qc(k) / ( qc(k) + qi(k) ) - ! ELSE - ! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one - ! ! species is very small, so make a temperature- - ! ! depedent guess - ! ENDIF - ! ELSE ! no explicit condensate, so make a temperature-dependent guess - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) - ! ENDIF - + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice qi_bl1D(k) = (1.0-liq_frac)*ql_ice - !Above tropopause: eliminate subgrid clouds from CB scheme - if (k .ge. k_tropo-1) then + !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was + !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds. + if (k .ge. k_tropo) then cldfra_bl1D(K) = 0. qc_bl1D(k) = 0. qi_bl1D(k) = 0. @@ -4018,8 +3935,12 @@ SUBROUTINE mym_condensation (kts,kte, & !Buoyancy-flux-related calculations follow... !limiting Q1 to avoid too much diffusion in cloud layers - q1k=max(Q1(k),-2.0) - + !q1k=max(Q1(k),-2.0) + if ((xland-1.5).GE.0) then ! water + q1k=max(Q1(k),-2.5) + else ! land + q1k=max(Q1(k),-2.0) + endif ! "Fng" represents the non-Gaussian transport factor ! (non-dimensional) from Bechtold et al. 1995 ! (hereafter BCMT95), section 3(c). Their suggested @@ -4032,23 +3953,28 @@ SUBROUTINE mym_condensation (kts,kte, & ! Fng = 1.-1.5*q1k !ENDIF ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) - IF (q1k .GE. 1.0) THEN + if (q1k .ge. 1.0) then Fng = 1.0 - ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN - Fng = EXP(-0.4*(q1k-1.0)) - ELSEIF (q1k .GE. -2.5 .AND. q1k .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(q1k+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) - ENDIF + elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then + Fng = exp(-0.4*(q1k-1.0)) + elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then + Fng = 3.0 + exp(-3.8*(q1k+1.7)) + else + Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys) + endif - cfmax= min(cldfra_bl1D(k), 0.5) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor + cfmax = min(cldfra_bl1D(k), 0.6_kind_phys) + !Further limit the cf going into vt & vq near the surface + zsl = min(max(25., 0.1*pblh2), 100.) + wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer + cfmax = cfmax*wt + + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor ! of T/theta. Strictly, b(k) above is formulated in ! terms of sat. mixing ratio, but bb in BCMT95 is ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. + ! conversion is neglected here. qww = 1.+0.61*qw(k) alpha = 0.61*th(k) beta = (th(k)/t)*(xl/cp) - 1.61*th(k) @@ -4064,8 +3990,8 @@ SUBROUTINE mym_condensation (kts,kte, & fac_damp = min(zagl * 0.0025, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.4) - cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) + cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) enddo END SELECT !end cloudPDF option @@ -4098,52 +4024,54 @@ END SUBROUTINE mym_condensation !>\ingroup gsd_mynn_edmf !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, !! qc, and qi - SUBROUTINE mynn_tendencies(kts,kte,i, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qnc,qni, & - &psfc,p,exner, & - &thl,sqv,sqc,sqi,sqw, & - &qnwfa,qnifa,qnbca,ozone, & - &ust,flt,flq,flqv,flqc,wspd, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & - &Dqnwfa,Dqnifa,Dqnbca,Dozone, & - &diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa,s_awqnbca, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv, & - &sd_awqc,sd_awu,sd_awv, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) + SUBROUTINE mynn_tendencies(kts,kte,i, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qs,qnc,qni, & + &psfc,p,exner, & + &thl,sqv,sqc,sqi,sqs,sqw, & + &qnwfa,qnifa,qnbca,ozone, & + &ust,flt,flq,flqv,flqc,wspd, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, & + &Dqnwfa,Dqnifa,Dqnbca,Dozone, & + &diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv, & + &sd_awqc,sd_awu,sd_awv, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &FLAG_OZONE, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i + integer, intent(in) :: kts,kte,i #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& - bl_mynn_edmf,bl_mynn_edmf_mom, & + integer, intent(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & + bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA + logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & + &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,FLAG_OZONE ! thl - liquid water potential temperature ! qw - total water @@ -4152,46 +4080,47 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! flq - surface flux of qw ! mass-flux plumes - REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & - &s_awqnwfa,s_awqnifa,s_awqnbca, & + real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw, & + &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment - REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& - &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& - &qnwfa,qnifa,qnbca,ozone,dfm,dfh - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,& - &psfc + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,& + &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & + &cldfra_bl1d,diss_heat + real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,& + &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh + real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, & + &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone + real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce + real(kind_phys), intent(in) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2,tk2,th2 - LOGICAL :: problem + real(kind_phys):: wsp,wsp2,tk2,th2 + logical :: problem integer :: kproblem -! REAL, INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top +! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top !local vars - REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING - qnwfa2,qnifa2,qnbca2,ozone2 - REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface - & khdz, kmdz - REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc - REAL :: ustdrag,ustdiff,qvflux - REAL :: th_new,portion_qc,portion_qi,condensate,qsat - INTEGER :: k,kk + real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp + real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & + &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 + real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface + &khdz,kmdz + real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc + real(kind_phys):: ustdrag,ustdiff,qvflux + real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat + integer :: k,kk !Activate nonlocal mixing from the mass-flux scheme for !number concentrations and aerosols (0.0 = no; 1.0 = yes) - REAL, PARAMETER :: nonloc = 1.0 + real(kind_phys), parameter :: nonloc = 1.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -4249,38 +4178,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & -! sub_u(k)*delt + det_u(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - & - & dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & -! !!!d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & - & sub_u(k)*delt + det_u(k)*delt - ENDDO + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*uoce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff & + & + sub_u(k)*delt + det_u(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff & + & + sub_u(k)*delt + det_u(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -4315,37 +4239,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & -! sub_v(k)*delt + det_v(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + & - & sub_v(k)*delt + det_v(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & -! !!!d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & - & sub_v(k)*delt + det_v(k)*delt - ENDDO + b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*voce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff & + & + sub_v(k)*delt + det_v(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff & + & + sub_v(k)*delt + det_v(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -4648,19 +4568,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt -! ENDDO - !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) @@ -4704,6 +4611,43 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & sqi2=sqi ENDIF +!============================================ +! MIX SNOW ( sqs ) +!============================================ +!hard-code to not mix snow +IF (bl_mynn_cloudmix > 0 .AND. .false.) THEN + + k=kts +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqs(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqs2) +! CALL tridiag3(kte,a,b,c,d,sqs2) + +! DO k=kts,kte +! sqs2(k)=d(k-kts+1) +! ENDDO +ELSE + sqs2=sqs +ENDIF + !!============================================ !! cloud ice number concentration (qni) !!============================================ @@ -4898,8 +4842,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnbca(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnbca2(k)=d(k-kts+1) @@ -4914,7 +4858,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !============================================ ! Ozone - local mixing only !============================================ - +IF (FLAG_OZONE) THEN k=kts !rho-weighted: @@ -4944,6 +4888,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !ozone2(k)=d(k-kts+1) dozone(k)=(x(k)-ozone(k))/delt ENDDO +ELSE + dozone(:)=0.0 +ENDIF !!============================================ !! Compute tendencies and convert to mixing ratios for WRF. @@ -4976,9 +4923,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & sqi2(k) = 0.0 ! if sqw2 > qsat sqc2(k) = 0.0 ENDIF - !dqv(k) = (sqv2(k) - sqv(k))/delt - !dqc(k) = (sqc2(k) - sqc(k))/delt - !dqi(k) = (sqi2(k) - sqi(k))/delt ENDDO ENDIF @@ -4987,7 +4931,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! WATER VAPOR TENDENCY !===================== DO k=kts,kte - Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + Dqv(k)=(sqv2(k) - sqv(k))/delt !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k ENDDO @@ -4998,7 +4942,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !print*,"FLAG_QC:",FLAG_QC IF (FLAG_QC) THEN DO k=kts,kte - Dqc(k)=(sqc2(k)/(1.-sqv2(k)) - qc(k))/delt + Dqc(k)=(sqc2(k) - sqc(k))/delt !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k ENDDO ELSE @@ -5026,7 +4970,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dqi(k)=(sqi2(k)/(1.-sqv2(k)) - qi(k))/delt + Dqi(k)=(sqi2(k) - sqi(k))/delt !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k ENDDO ELSE @@ -5035,6 +4979,19 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDDO ENDIF + !=================== + ! CLOUD SNOW TENDENCY + !=================== + IF (.false.) THEN !disabled + DO k=kts,kte + Dqs(k)=(sqs2(k) - sqs(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqs(k) = 0. + ENDDO + ENDIF + !=================== ! CLOUD ICE NUM CONC TENDENCY !=================== @@ -5051,17 +5008,18 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ELSE !-MIX CLOUD SPECIES? !CLOUDS ARE NOT NIXED (when bl_mynn_cloudmix == 0) DO k=kts,kte - Dqc(k)=0. + Dqc(k) =0. Dqnc(k)=0. - Dqi(k)=0. + Dqi(k) =0. Dqni(k)=0. + Dqs(k) =0. ENDDO ENDIF !ensure non-negative moist species - CALL moisture_check(kte, delt, delp, exner, & - sqv2, sqc2, sqi2, thl, & - dqv, dqc, dqi, dth ) + CALL moisture_check(kte, delt, delp, exner, & + sqv2, sqc2, sqi2, sqs2, thl, & + dqv, dqc, dqi, dqs, dth ) !===================== ! OZONE TENDENCY CHECK @@ -5077,8 +5035,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & - & + xlscp/exner(k)*sqi2(k) & + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & + & + xlscp/exner(k)*(sqi2(k)) & !+sqs(k)) & & - th(k))/delt !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy: @@ -5110,15 +5068,23 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! Ice-friendly aerosols !===================== Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt - !===================== - ! Black-carbon aerosols - !===================== - Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt ENDDO ELSE DO k=kts,kte Dqnwfa(k)=0. Dqnifa(k)=0. + ENDDO + ENDIF + + !======================== + ! BLACK-CARBON TENDENCIES + !======================== + IF (FLAG_QNBCA .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt + ENDDO + ELSE + DO k=kts,kte Dqnbca(k)=0. ENDDO ENDIF @@ -5168,9 +5134,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & END SUBROUTINE mynn_tendencies ! ================================================================== - SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, th, & - dqv, dqc, dqi, dth ) + SUBROUTINE moisture_check(kte, delt, dp, exner, & + qv, qc, qi, qs, th, & + dqv, dqc, dqi, dqs, dth ) ! This subroutine was adopted from the CAM-UW ShCu scheme and ! adapted for use here. @@ -5186,33 +5152,36 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & ! applying corresponding input tendencies and corrective tendencies. implicit none - integer, intent(in) :: kte - real, intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th - real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth + integer, intent(in) :: kte + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th + real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum - real, parameter :: qvmin = 1e-20, & - qcmin = 0.0, & - qimin = 0.0 + real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum + real(kind_phys), parameter :: qvmin = 1e-20, & + qcmin = 0.0, & + qimin = 0.0 do k = kte, 1, -1 ! From the top to the surface dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) !fix tendencies dqc(k) = dqc(k) + dqc2/delt dqi(k) = dqi(k) + dqi2/delt - dqv(k) = dqv(k) - (dqc2+dqi2)/delt + dqs(k) = dqs(k) + dqs2/delt + dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & - xlscp/exner(k)*(dqi2/delt) + xlscp/exner(k)*((dqi2+dqs2)/delt) !update species qc(k) = qc(k) + dqc2 qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 + qs(k) = qs(k) + dqs2 + qv(k) = qv(k) - dqc2 - dqi2 - dqs2 th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - xlscp/exner(k)*dqi2 + xlscp/exner(k)*(dqi2+dqs2) !then fix qv dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) @@ -5225,6 +5194,7 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & qv(k) = max(qv(k),qvmin) qc(k) = max(qc(k),qcmin) qi(k) = max(qi(k),qimin) + qs(k) = max(qs(k),qimin) end do ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally ! extracted from all the layers that has 'qv > 2*qvmin'. This fully @@ -5267,35 +5237,36 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & enh_mix, smoke_dbg ) !------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte,i - REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: delt,flt,pblh - INTEGER, INTENT(IN) :: nchem, kdvel, ndvel - REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL, INTENT(IN) :: emis_ant_no,frp - LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg + integer, intent(in) :: kts,kte,i + real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd + real(kind_phys), dimension(kts:kte), intent(inout) :: rho + real(kind_phys), intent(in) :: flt + real(kind_phys), intent(in) :: delt,pblh + integer, intent(in) :: nchem, kdvel, ndvel + real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw + real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1 + real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem + real(kind_phys), dimension( ndvel ), intent(in) :: vd1 + real(kind_phys), intent(in) :: emis_ant_no,frp + logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg !local vars - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL :: rhs,dztop - REAL :: t,dzk - REAL :: hght - REAL :: khdz_old, khdz_back - INTEGER :: k,kk,kmaxfire ! JLS 12/21/21 - INTEGER :: ic ! Chemical array loop index + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + real(kind_phys):: rhs,dztop + real(kind_phys):: t,dzk + real(kind_phys):: hght + real(kind_phys):: khdz_old, khdz_back + integer :: k,kk,kmaxfire ! JLS 12/21/21 + integer :: ic ! Chemical array loop index - INTEGER, SAVE :: icall + integer, SAVE :: icall - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources - REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - REAL, PARAMETER :: pblh_threshold = 100.0 + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz + real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources + real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + real(kind_phys), parameter :: pblh_threshold = 100.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5389,15 +5360,15 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& !------------------------------------------------------------------- - INTEGER , INTENT(in) :: kts,kte + integer , intent(in) :: kts,kte - REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh - REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h - INTEGER :: k - REAL :: dzk + integer :: k + real(kind_phys):: dzk K_m(kts)=0. K_h(kts)=0. @@ -5422,13 +5393,13 @@ SUBROUTINE tridiag(n,a,b,c,d) !------------------------------------------------------------------- - INTEGER, INTENT(in):: n - REAL, DIMENSION(n), INTENT(in) :: a,b - REAL, DIMENSION(n), INTENT(inout) :: c,d + integer, intent(in):: n + real(kind_phys), dimension(n), intent(in) :: a,b + real(kind_phys), dimension(n), intent(inout) :: c,d - INTEGER :: i - REAL :: p - REAL, DIMENSION(n) :: q + integer :: i + real(kind_phys):: p + real(kind_phys), dimension(n) :: q c(n)=0. q(1)=-c(1)/b(1) @@ -5458,10 +5429,10 @@ subroutine tridiag2(n,a,b,c,d,x) ! n - number of unknowns (levels) integer,intent(in) :: n - real, dimension(n),intent(in) :: a,b,c,d - real ,dimension(n),intent(out) :: x - real ,dimension(n) :: cp,dp - real :: m + real(kind_phys), dimension(n), intent(in) :: a,b,c,d + real(kind_phys), dimension(n), intent(out):: x + real(kind_phys), dimension(n) :: cp,dp + real(kind_phys):: m integer :: i ! initialize c-prime and d-prime @@ -5500,12 +5471,12 @@ subroutine tridiag3(kte,a,b,c,d,x) implicit none integer,intent(in) :: kte integer, parameter :: kts=1 - real, dimension(kte) :: a,b,c,d - real ,dimension(kte),intent(out) :: x + real(kind_phys), dimension(kte) :: a,b,c,d + real(kind_phys), dimension(kte), intent(out) :: x integer :: in ! integer kms,kme,kts,kte,in -! real a(kms:kme,3),c(kms:kme),x(kms:kme) +! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme) do in=kte-1,kts,-1 d(in)=d(in)-c(in)*d(in+1)/b(in+1) @@ -5562,23 +5533,23 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) !value could be found to work best in all conditions. !--------------------------------------------------------------- - INTEGER,INTENT(IN) :: KTS,KTE + integer,intent(in) :: KTS,KTE #ifdef HARDCODE_VERTICAL # define kts 1 # define kte HARDCODE_VERTICAL #endif - 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 + real(kind_phys), intent(out) :: zi + real(kind_phys), intent(in) :: landsea + real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). - REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). - INTEGER :: I,J,K,kthv,ktke,kzi + real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point + real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m). + real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m). + integer :: I,J,K,kthv,ktke,kzi !Initialize KPBL (kzi) kzi = 2 @@ -5743,12 +5714,12 @@ SUBROUTINE DMP_mf( & & F_QNWFA,F_QNIFA,F_QNBCA, & & Psig_shcu, & ! output info - &nup2,ktop,maxmf,ztop, & - ! unputs for stochastic perturbations - &spp_pbl,rstoch_col ) + & maxwidth,ktop,maxmf,ztop, & + ! inputs for stochastic perturbations + & spp_pbl,rstoch_col ) ! inputs: - INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt + integer, intent(in) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt #ifdef HARDCODE_VERTICAL # define kts 1 @@ -5756,133 +5727,138 @@ SUBROUTINE DMP_mf( & #endif ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: & - u,v,w,th,thl,tk,qt,qv,qc, & - exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma - REAL, INTENT(IN) :: dt,ust,flt,fltv,flq,flqv,pblh, & - dx,psig_shcu,landsea,ts - LOGICAL, OPTIONAL :: f_qc,f_qi,f_qnc,f_qni, & - f_qnwfa,f_qnifa,f_qnbca + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col + + real(kind_phys),dimension(kts:kte), intent(in) :: & + &U,V,W,TH,THL,TK,QT,QV,QC, & + &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca + real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma + real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, & + &landsea,ts,dx,dt,ust,pblh + logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA ! outputs - updraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, & & edmf_qt,edmf_thl,edmf_ent,edmf_qc !add one local edmf variable: - REAL,DIMENSION(KTS:KTE) :: edmf_th + real(kind_phys),dimension(kts:kte) :: edmf_th ! output - INTEGER, INTENT(OUT) :: nup2,ktop - REAL, INTENT(OUT) :: maxmf,ztop - ! outputs - variables needed for solver - sum ai*rho*wis_awphi - REAL,DIMENSION(KTS:KTE+1) :: s_aw,s_awthl,s_awqt, & - s_awqv,s_awqc,s_awqnc,s_awqni, & - s_awqnwfa,s_awqnifa,s_awqnbca, & - s_awu,s_awv,s_awqke,s_aw2 + integer, intent(out) :: ktop + real(kind_phys), intent(out) :: maxmf,ztop,maxwidth + ! outputs - variables needed for solver + real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi + &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & + &s_awqke,s_aw2 - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & - qc_bl1d_old,cldfra_bl1d_old + real(kind_phys),dimension(kts:kte), intent(inout) :: & + &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old - INTEGER, PARAMETER :: nup=10, debug_mf=0 + integer, parameter :: nup=8, debug_mf=0 + real(kind_phys) :: nup2 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & - UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - UPQNI,UPQNWFA,UPQNIFA,UPQNBCA + real(kind_phys),dimension(kts:kte+1,1:NUP) :: & + &UPW,UPTHL,UPQT,UPQC,UPQV, & + &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & + &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA ! entrainment variables - REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf - INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf + integer,dimension(kts:kte,1:NUP) :: ENTi ! internal variables - INTEGER :: K,I,k50 - REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & - QNWFAn,QNIFAn,QNBCAn, & - Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + integer :: K,I,k50 + real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & + &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & + & QNWFAn,QNIFAn,QNBCAn, & + & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters - REAL,PARAMETER :: & - &Wa=2./3., & - &Wb=0.002, & + real(kind_phys), parameter :: & + &Wa=2./3., & + &Wb=0.002, & &Wc=1.5 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - REAL,PARAMETER :: & - & L0=100., & - & ENT0=0.1 - - ! Implement ideas from Neggers (2016, JAMES): - REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts - REAL, PARAMETER :: lmax = 1000.! diameter of largest plume - REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand - REAL, PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + real(kind_phys),parameter :: & + & L0=100., & + & ENT0=0.1 + + ! Parameters/variables for regulating plumes: + real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts + real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller) + real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger) + real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv) + real(kind_phys) :: minwidth ! actual width of smallest plume + real(kind_phys) :: dl ! variable increment of plume size + real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) + real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx ! chem/smoke - INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(:, :) :: chem1 - REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem - REAL,DIMENSION(nchem) :: chemn - REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM - INTEGER :: ic - REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem - LOGICAL, INTENT(IN) :: mix_chem + integer, intent(in) :: nchem + real(kind_phys),dimension(:, :) :: chem1 + real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem + real(kind_phys),dimension(nchem) :: chemn + real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM + integer :: ic + real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem + logical, intent(in) :: mix_chem !JOE: add declaration of ERF - REAL :: ERF + real(kind_phys):: ERF - LOGICAL :: superadiabatic + logical :: superadiabatic ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& - Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & + real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm + real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf - REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value + real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check - REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl - REAL :: csigma,acfac,ac_wsp,ac_cld + real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz + real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl + real(kind_phys):: csigma,acfac,ac_wsp !plume overshoot - INTEGER :: overshoot - REAL :: bvf, Frz, dzp + integer :: overshoot + real(kind_phys):: bvf, Frz, dzp !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). !This limiter makes adjustments to the entire column. - REAL :: adjustment, flx1 - REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + real(kind_phys):: adjustment, flx1, flt2 + real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that + ! 0.5 starts to have a noticeable impact ! over land (decrease maxMF by 10-20%), but no impact over water. !Subsidence - REAL,DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence - det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment - envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & + real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence + det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment + envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & envm_u,envm_v !environmental variables defined at middle of layer - REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface - REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& - qc_plume,exc_heat,exc_moist,tk_int - REAL, PARAMETER :: Cdet = 1./45. - REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers + real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface + real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & + detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & + qc_plume,exc_heat,exc_moist,tk_int,tvs + real(kind_phys), parameter :: Cdet = 1./45. + real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme !is compensated by "gentle" environmental subsidence. - REAL, PARAMETER :: Csub=0.25 + real(kind_phys), parameter :: Csub=0.25 !Factor for the pressure gradient effects on momentum transport - REAL, PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere - REAL :: Uk,Ukm1,Vk,Vkm1,dxsa + real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa ! check the inputs ! print *,'dt',dt @@ -5912,9 +5888,9 @@ SUBROUTINE DMP_mf( & UPQNWFA=0. UPQNIFA=0. UPQNBCA=0. - IF ( mix_chem ) THEN - UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 - ENDIF + if ( mix_chem ) then + UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0 + endif ENT=0.001 ! Initialize mean updraft properties @@ -5924,9 +5900,9 @@ SUBROUTINE DMP_mf( & edmf_thl=0. edmf_ent=0. edmf_qc =0. - IF ( mix_chem ) THEN + if ( mix_chem ) then edmf_chem(kts:kte+1,1:nchem) = 0.0 - ENDIF + endif ! Initialize the variables needed for implicit solver s_aw=0. @@ -5942,153 +5918,160 @@ SUBROUTINE DMP_mf( & s_awqnwfa=0. s_awqnifa=0. s_awqnbca=0. - IF ( mix_chem ) THEN + if ( mix_chem ) then s_awchem(kts:kte+1,1:nchem) = 0.0 - ENDIF + endif ! Initialize explicit tendencies for subsidence & detrainment sub_thl = 0. sub_sqv = 0. - sub_u = 0. - sub_v = 0. + sub_u = 0. + sub_v = 0. det_thl = 0. det_sqv = 0. det_sqc = 0. - det_u = 0. - det_v = 0. + det_u = 0. + det_v = 0. + nup2 = nup !start with nup, but set to zero if activation criteria fails ! Taper off MF scheme when significant resolved-scale motions ! are present This function needs to be asymetric... - k = 1 - maxw = 0.0 + maxw = 0.0 cloud_base = 9000.0 -! DO WHILE (ZW(k) < pblh + 500.) - DO k=1,kte-1 - IF(zw(k) > pblh + 500.) exit + do k=1,kte-1 + if (zw(k) > pblh + 500.) exit wpbl = w(k) - IF(w(k) < 0.)wpbl = 2.*w(k) - maxw = MAX(maxw,ABS(wpbl)) + if (w(k) < 0.)wpbl = 2.*w(k) + maxw = max(maxw,abs(wpbl)) !Find highest k-level below 50m AGL - IF(ZW(k)<=50.)k50=k + if (ZW(k)<=50.)k50=k !Search for cloud base - qc_sgs = MAX(qc(k), qc_bl1d(k)*cldfra_bl1d(k)) - IF(qc_sgs> 1E-5 .AND. cloud_base == 9000.0)THEN + qc_sgs = max(qc(k), qc_bl1d(k)) + if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then cloud_base = 0.5*(ZW(k)+ZW(k+1)) - ENDIF + endif + enddo - !k = k + 1 - ENDDO - !print*," maxw before manipulation=", maxw - maxw = MAX(0.,maxw - 1.0) ! do nothing for small w (< 1 m/s), but - Psig_w = MAX(0.0, 1.0 - maxw) ! linearly taper off for w > 1.0 m/s - Psig_w = MIN(Psig_w, Psig_shcu) - !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s + maxw = max(0.,maxw - 1.0) + Psig_w = max(0.0, 1.0 - maxw) + Psig_w = min(Psig_w, Psig_shcu) !Completely shut off MF scheme for strong resolved-scale vertical velocities. fltv2 = fltv - IF(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv + if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv ! If surface buoyancy is positive we do integration, otherwise no. ! Also, ensure that it is at least slightly superadiabatic up through 50 m superadiabatic = .false. - IF((landsea-1.5).GE.0)THEN + if ((landsea-1.5).ge.0) then hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. - ELSE + else hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. - ENDIF - DO k=1,MAX(1,k50-1) !use "-1" because k50 used interface heights (zw). - IF (k == 1) then - IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN + endif + tvs = ts*(1.0+p608*qv(kts)) + do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw). + if (k == 1) then + if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then superadiabatic = .true. - ELSE + else superadiabatic = .false. exit - ENDIF - ELSE - IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN + endif + else + if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then superadiabatic = .true. - ELSE + else superadiabatic = .false. exit - ENDIF - ENDIF - ENDDO + endif + endif + enddo ! Determine the numer of updrafts/plumes in the grid column: ! Some of these criteria may be a little redundant but useful for bullet-proofing. - ! (1) largest plume = 1.0 * dx. - ! (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist. + ! (1) largest plume = 1.2 * dx. + ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist. ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only ! meant to "soften" the activation of the mass-flux scheme. ! Criteria (1) - NUP2 = max(1,min(NUP,INT(dx*dcut/dl))) + maxwidth = min(dx*dcut, lmax) !Criteria (2) - maxwidth = 1.1*PBLH + maxwidth = min(maxwidth, 1.1_kind_phys*PBLH) ! Criteria (3) - maxwidth = MIN(maxwidth,0.5*cloud_base) + if ((landsea-1.5) .lt. 0) then !land + maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base) + else !water + maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base) + endif ! Criteria (4) - wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01)) + wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys)) !Note: area fraction (acfac) is modified below ! Criteria (5) - only a function of flt (not fltv) if ((landsea-1.5).LT.0) then !land - !width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.050)/0.03) + .5),1000.), 0.) - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.040)/0.03) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys) else !water - width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.003)/0.01) + .5),1000.), 0.) + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys) + endif + maxwidth = MIN(maxwidth, width_flx) + minwidth = lmin + !allow min plume size to increase in large flux conditions (eddy diffusivity should be + !large enough to handle the representation of small plumes). + if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys) + + if (maxwidth .le. minwidth) then ! deactivate MF component + nup2 = 0 + maxwidth = 0.0 endif - maxwidth = MIN(maxwidth,width_flx) - ! Convert maxwidth to number of plumes - NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2) - !Initialize values for 2d output fields: - ktop = 0 - ztop = 0.0 - maxmf= 0.0 + ! Initialize values for 2d output fields: + ktop = 0 + ztop = 0.0 + maxmf= 0.0 - IF ( fltv2 > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then - !PRINT*," Conditions met to run mass-flux scheme",fltv2,pblh +!Begin plume processing if passes criteria +if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then ! Find coef C for number size density N cn = 0. - d=-1.9 !set d to value suggested by Neggers 2015 (JAMES). - !d=-1.9 + .2*tanh((fltv2 - 0.05)/0.15) - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume + d =-1.9 !set d to value suggested by Neggers 2015 (JAMES). + dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys) + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume enddo C = Atot/cn !Normalize C according to the defined total fraction (Atot) ! Make updraft area (UPA) a function of the buoyancy flux - if ((landsea-1.5).LT.0) then !land - !acfac = .5*tanh((fltv2 - 0.03)/0.09) + .5 - !acfac = .5*tanh((fltv2 - 0.02)/0.09) + .5 - acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 - else !water - acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 - endif + acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 + !add a windspeed-dependent adjustment to acfac that tapers off - !the mass-flux scheme linearly above sfc wind speeds of 20 m/s: - ac_wsp = 1.0 - min(max(wspd_pbl - 20.0, 0.0), 10.0)/10.0 - !reduce area fraction beneath cloud bases < 1200 m AGL - ac_cld = min(cloud_base/1200., 1.0) - acfac = acfac * min(ac_wsp, ac_cld) + !the mass-flux scheme linearly above sfc wind speeds of 10 m/s. + !Note: this effect may be better represented by an increase in + !entrainment rate for high wind consitions (more ambient turbulence). + if (wspd_pbl .le. 10.) then + ac_wsp = 1.0 + else + ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0) + endif + acfac = acfac * ac_wsp ! Find the portion of the total fraction (Atot) of each plume size: An2 = 0. - do I=1,NUP !NUP2 - IF(I > NUP2) exit - l = dl*I ! diameter of plume + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) N = C*l**d ! number density of plume n - UPA(1,I) = N*l*l/(dx*dx) * dl ! fractional area of plume n + UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n - UPA(1,I) = UPA(1,I)*acfac - An2 = An2 + UPA(1,I) ! total fractional area of all plumes + UPA(1,i) = UPA(1,i)*acfac + An2 = An2 + UPA(1,i) ! total fractional area of all plumes !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 end do @@ -6101,23 +6084,25 @@ SUBROUTINE DMP_mf( & qstar=max(flq,1.0E-5)/wstar thstar=flt/wstar - IF((landsea-1.5).GE.0)THEN + if ((landsea-1.5) .ge. 0) then csigma = 1.34 ! WATER - ELSE + else csigma = 1.34 ! LAND - ENDIF + endif if (env_subs) then exc_fac = 0.0 else if ((landsea-1.5).GE.0) then !water: increase factor to compensate for decreased pwmin/pwmax - exc_fac = 0.58*4.0*min(cloud_base/1000., 1.0) + exc_fac = 0.58*4.0 else !land: no need to increase factor - already sufficiently large superadiabatic layers exc_fac = 0.58 endif endif + !decrease excess for large wind speeds + exc_fac = exc_fac * ac_wsp !Note: sigmaW is typically about 0.5*wstar sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) @@ -6130,14 +6115,11 @@ SUBROUTINE DMP_mf( & wmax=MIN(sigmaW*pwmax,0.5) !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + do i=1,NUP wlv=wmin+(wmax-wmin)/NUP2*(i-1) !SURFACE UPDRAFT VERTICAL VELOCITY - UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin) - !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt - + UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQC(1,I)=0.0 @@ -6146,21 +6128,11 @@ SUBROUTINE DMP_mf( & exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & & + exc_heat -!was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & & + exc_heat !calculate exc_moist by use of surface fluxes exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW - !calculate exc_moist by conserving rh: -! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) -! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) -! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) -! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p -! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001) -! tk_int = tk_int + exc_heat -! qsat_tk = qsat_blend(tk_int, pk) -! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0) UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& & +exc_moist @@ -6170,36 +6142,36 @@ SUBROUTINE DMP_mf( & UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - ENDDO + enddo - IF ( mix_chem ) THEN - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + if ( mix_chem ) then + do i=1,NUP do ic = 1,nchem - UPCHEM(1,I,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) enddo - ENDDO - ENDIF + enddo + endif !Initialize environmental variables which can be modified by detrainment - DO k=kts,kte - envm_thl(k)=THL(k) - envm_sqv(k)=QV(k) - envm_sqc(k)=QC(k) - envm_u(k)=U(k) - envm_v(k)=V(k) - ENDDO + envm_thl(kts:kte)=THL(kts:kte) + envm_sqv(kts:kte)=QV(kts:kte) + envm_sqc(kts:kte)=QC(kts:kte) + envm_u(kts:kte)=U(kts:kte) + envm_v(kts:kte)=V(kts:kte) + do k=kts,kte-1 + rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) + enddo + rhoz(kte) = rho(kte) !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) ! do integration updraft - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + do i=1,NUP QCn = 0. overshoot = 0 - l = dl*I ! diameter of plume - DO k=KTS+1,KTE-1 + l = minwidth + dl*real(i-1) ! diameter of plume + do k=kts+1,kte-1 !Entrainment from Tian and Kuang (2016) !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh @@ -6214,7 +6186,7 @@ SUBROUTINE DMP_mf( & ENT(k,i) = max(ENT(k,i),0.0003) !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang - !JOE - increase entrainment for plumes extending very high. + !increase entrainment for plumes extending very high. IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6 ENDIF @@ -6339,13 +6311,10 @@ SUBROUTINE DMP_mf( & dzp = dz(k) ENDIF - !Limit very tall plumes - Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3500.),0.0)/1000.) - - !JOE- minimize the plume penetratration in stratocu-topped PBL - ! IF (fltv2 < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - ! ENDIF + !minimize the plume penetratration in stratocu-topped PBL + !IF (fltv2 < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + !ENDIF !Modify environment variables (representative of the model layer - envm*) !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS). @@ -6395,6 +6364,7 @@ SUBROUTINE DMP_mf( & exit !exit k-loop END IF ENDDO + IF (debug_mf == 1) THEN IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN @@ -6414,104 +6384,105 @@ SUBROUTINE DMP_mf( & ENDIF ENDIF ENDDO - ELSE +ELSE !At least one of the conditions was not met for activating the MF scheme. NUP2=0. - END IF !end criteria for mass-flux scheme - - ktop=MIN(ktop,KTE-1) ! Just to be safe... - IF (ktop == 0) THEN - ztop = 0.0 - ELSE - ztop=zw(ktop) - ENDIF +END IF !end criteria check for mass-flux scheme - IF(nup2 > 0) THEN +ktop=MIN(ktop,KTE-1) +IF (ktop == 0) THEN + ztop = 0.0 +ELSE + ztop=zw(ktop) +ENDIF - !Calculate the fluxes for each variable - !All s_aw* variable are == 0 at k=1 - DO i=1,NUP !NUP2 - IF(I > NUP2) exit +IF (nup2 > 0) THEN + !Calculate the fluxes for each variable + !All s_aw* variable are == 0 at k=1 + DO i=1,NUP DO k=KTS,KTE-1 - IF(k > ktop) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - s_aw(k+1) = s_aw(k+1) + rho_int*UPA(K,i)*UPW(K,i)*Psig_w - s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w - s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w + s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w !to conform to grid mean properties, move qc to qv in grid mean !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. - IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then +! if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then qc_plume = UPQC(K,i) - ELSE - qc_plume = 0.0 - ENDIF - s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w - IF (momentum_opt > 0) THEN - s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w - s_awv(k+1) = s_awv(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w - ENDIF - IF (tke_opt > 0) THEN - s_awqke(k+1)= s_awqke(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w - ENDIF +! else +! qc_plume = 0.0 +! endif + s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) ENDDO - ENDDO - - IF ( mix_chem ) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO i=1,NUP !NUP2 - IF(I > NUP2) exit - do ic = 1,nchem - s_awchem(k+1,ic) = s_awchem(k+1,ic) + rho_int*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w - enddo - ENDDO - ENDDO - ENDIF - - IF (scalar_opt > 0) THEN - DO k=KTS,KTE - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NUP !NUP2 - IF (I > NUP2) exit - s_awqnc(k+1)= s_awqnc(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w - s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w - s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w - s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w - s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w - ENDDO - ENDDO - ENDIF + ENDDO + !momentum + if (momentum_opt > 0) then + do i=1,nup + do k=kts,kte-1 + s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + enddo + enddo + endif + !tke + if (tke_opt > 0) then + do i=1,nup + do k=kts,kte-1 + s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + enddo + enddo + endif + !chem + if ( mix_chem ) then + do k=kts,kte + do i=1,nup + do ic = 1,nchem + s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + enddo + enddo + enddo + endif + + if (scalar_opt > 0) then + do k=kts,kte + do I=1,nup + s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w + enddo + enddo + endif - !Flux limiter: Check ratio of heat flux at top of first model layer - !and at the surface. Make sure estimated flux out of the top of the - !layer is < fluxportion*surface_heat_flux - IF (s_aw(kts+1) /= 0.) THEN + !Flux limiter: Check ratio of heat flux at top of first model layer + !and at the surface. Make sure estimated flux out of the top of the + !layer is < fluxportion*surface_heat_flux + IF (s_aw(kts+1) /= 0.) THEN dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5) - ELSE + ELSE flx1 = 0.0 !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,& ! " superadiabatic=",superadiabatic," KTOP=",KTOP - ENDIF - adjustment=1.0 - !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 - !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) - IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN - adjustment= fluxportion*flt/dz(kts)/flx1 - s_aw = s_aw*adjustment - s_awthl= s_awthl*adjustment - s_awqt = s_awqt*adjustment - s_awqc = s_awqc*adjustment - s_awqv = s_awqv*adjustment - s_awqnc= s_awqnc*adjustment - s_awqni= s_awqni*adjustment - s_awqnwfa= s_awqnwfa*adjustment - s_awqnifa= s_awqnifa*adjustment - s_awqnbca= s_awqnbca*adjustment + ENDIF + adjustment=1.0 + flt2=max(flt,0.0) !need because activation is now based on fltv, not flt + !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 + !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) + IF (flx1 > fluxportion*flt2/dz(kts) .AND. flx1>0.0) THEN + adjustment= fluxportion*flt2/dz(kts)/flx1 + s_aw = s_aw*adjustment + s_awthl = s_awthl*adjustment + s_awqt = s_awqt*adjustment + s_awqc = s_awqc*adjustment + s_awqv = s_awqv*adjustment + s_awqnc = s_awqnc*adjustment + s_awqni = s_awqni*adjustment + s_awqnwfa = s_awqnwfa*adjustment + s_awqnifa = s_awqnifa*adjustment + s_awqnbca = s_awqnbca*adjustment IF (momentum_opt > 0) THEN s_awu = s_awu*adjustment s_awv = s_awv*adjustment @@ -6523,62 +6494,57 @@ SUBROUTINE DMP_mf( & s_awchem = s_awchem*adjustment ENDIF UPA = UPA*adjustment - ENDIF - !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt - - !Calculate mean updraft properties for output: - !all edmf_* variables at k=1 correspond to the interface at top of first model layer - DO k=KTS,KTE-1 - IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) - DO I=1,NUP !NUP2 - IF(I > NUP2) exit - edmf_a(K) =edmf_a(K) +UPA(K,i) - edmf_w(K) =edmf_w(K) +rho_int*UPA(K,i)*UPW(K,i) - edmf_qt(K) =edmf_qt(K) +rho_int*UPA(K,i)*UPQT(K,i) - edmf_thl(K)=edmf_thl(K)+rho_int*UPA(K,i)*UPTHL(K,i) - edmf_ent(K)=edmf_ent(K)+rho_int*UPA(K,i)*ENT(K,i) - edmf_qc(K) =edmf_qc(K) +rho_int*UPA(K,i)*UPQC(K,i) - ENDDO - + ENDIF + !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt + + !Calculate mean updraft properties for output: + !all edmf_* variables at k=1 correspond to the interface at top of first model layer + do k=kts,kte-1 + do I=1,nup + edmf_a(K) =edmf_a(K) +UPA(K,i) + edmf_w(K) =edmf_w(K) +UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +UPA(K,i)*UPQC(K,i) + enddo + enddo + do k=kts,kte-1 !Note that only edmf_a is multiplied by Psig_w. This takes care of the !scale-awareness of the subsidence below: - IF (edmf_a(k)>0.) THEN - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_a(k)=edmf_a(k)*Psig_w - - !FIND MAXIMUM MASS-FLUX IN THE COLUMN: - IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) - ENDIF - ENDDO ! end k - - !smoke/chem - IF ( mix_chem ) THEN - DO k=kts,kte-1 - IF(k > KTOP) exit - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) - DO I=1,NUP !NUP2 - IF(I > NUP2) exit + if (edmf_a(k)>0.) then + edmf_w(k)=edmf_w(k)/edmf_a(k) + edmf_qt(k)=edmf_qt(k)/edmf_a(k) + edmf_thl(k)=edmf_thl(k)/edmf_a(k) + edmf_ent(k)=edmf_ent(k)/edmf_a(k) + edmf_qc(k)=edmf_qc(k)/edmf_a(k) + edmf_a(k)=edmf_a(k)*Psig_w + !FIND MAXIMUM MASS-FLUX IN THE COLUMN: + if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) + endif + enddo ! end k + + !smoke/chem + if ( mix_chem ) then + do k=kts,kte-1 + do I=1,nup do ic = 1,nchem - edmf_chem(k,ic) = edmf_chem(k,ic) + rho_int*UPA(K,I)*UPCHEM(k,i,ic) + edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic) enddo - ENDDO - - IF (edmf_a(k)>0.) THEN + enddo + enddo + do k=kts,kte-1 + if (edmf_a(k)>0.) then do ic = 1,nchem edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) enddo - ENDIF - ENDDO ! end k - ENDIF + endif + enddo ! end k + endif - !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables - IF (env_subs) THEN + !Calculate the effects environmental subsidence. + !All envi_*variables are valid at the interfaces, like the edmf_* variables + IF (env_subs) THEN DO k=kts+1,kte-1 !First, smooth the profiles of w & a, since sharp vertical gradients !in plume variables are not likely extended to env variables @@ -6613,18 +6579,16 @@ SUBROUTINE DMP_mf( & !calculate tendencies from subsidence and detrainment valid at the middle of !each model layer. The lowest model layer uses an assumes w=0 at the surface. dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) - rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int + (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k) sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int + (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k) DO k=kts+1,kte-1 dzi(k) = 0.5*(dz(k)+dz(k+1)) - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int + (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k) sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int + (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k) ENDDO DO k=KTS,KTE-1 @@ -6634,17 +6598,15 @@ SUBROUTINE DMP_mf( & ENDDO IF (momentum_opt > 0) THEN - rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int + (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k) sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & - (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int + (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k) DO k=kts+1,kte-1 - rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int + (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k) sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int + (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k) ENDDO DO k=KTS,KTE-1 @@ -6652,23 +6614,23 @@ SUBROUTINE DMP_mf( & det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w ENDDO ENDIF - ENDIF !end subsidence/env detranment + ENDIF !end subsidence/env detranment - !First, compute exner, plume theta, and dz centered at interface - !Here, k=1 is the top of the first model layer. These values do not - !need to be defined at k=kte (unused level). - DO K=KTS,KTE-1 - exneri(k) = (exner(k)*DZ(k+1)+exner(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + !First, compute exner, plume theta, and dz centered at interface + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). + DO K=KTS,KTE-1 + exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k)) edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) - dzi(k) = 0.5*(DZ(k)+DZ(k+1)) - ENDDO + dzi(k) = 0.5*(dz(k)+dz(k+1)) + ENDDO !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in ! mym_condensation. Here, a shallow-cu component is added, but no cumulus ! clouds can be added at k=1 (start loop at k=2). - DO K=KTS+1,KTE-2 - IF(k > KTOP) exit - IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + do k=kts+1,kte-2 + if (k > KTOP) exit + if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN !interpolate plume quantities to mass levels Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) @@ -6681,11 +6643,11 @@ SUBROUTINE DMP_mf( & qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) !condensed liquid in the plume on mass levels - IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN + if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - ELSE - QCp = MAX(edmf_qc(k),edmf_qc(k-1)) - ENDIF + else + QCp = max(edmf_qc(k),edmf_qc(k-1)) + endif !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq xl = xl_blend(tk(k)) ! obtain blended heat capacity @@ -6721,7 +6683,7 @@ SUBROUTINE DMP_mf( & !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components !Per S.DeRoode 2009? - !sigq = 4. * Aup * (QTp - qt(k)) + !sigq = 5. * Aup * (QTp - qt(k)) sigq = 10. * Aup * (QTp - qt(k)) !constrain sigq wrt saturation: sigq = max(sigq, qsat_tk*0.02 ) @@ -6742,17 +6704,10 @@ SUBROUTINE DMP_mf( & !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) !Original CB mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) - mf_cf = max(mf_cf, 1.75 * Aup) - mf_cf = min(mf_cf, 5.0 * Aup) + mf_cf = max(mf_cf, 1.8 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) endif - ! WA TEST 4/15/22 use fit to Aup rather than CB - !IF (Aup > 0.1) THEN - ! mf_cf = 2.5 * Aup - !ELSE - ! mf_cf = 1.8 * Aup - !ENDIF - !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk @@ -6764,30 +6719,20 @@ SUBROUTINE DMP_mf( & ! Update cloud fractions and specific humidities in grid cells ! where the mass-flux scheme is active. The specific humidities ! are converted to grid means (not in-cloud quantities). - if ((landsea-1.5).GE.0) then ! water - !don't overwrite stratus CF & qc_bl - degrades marine stratus - if (cldfra_bl1d(k) < cf_thresh) then - if (QCp * Aup > 5e-5) then - qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 - else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - if (mf_cf .ge. Aup) then - qc_bl1d(k) = qc_bl1d(k) / mf_cf - endif - cldfra_bl1d(k) = mf_cf - Ac_mf = mf_cf + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf else ! land if (QCp * Aup > 5e-5) then qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 else qc_bl1d(k) = 1.18 * (QCp * Aup) endif - if (mf_cf .ge. Aup) then - qc_bl1d(k) = qc_bl1d(k) / mf_cf - endif cldfra_bl1d(k) = mf_cf Ac_mf = mf_cf endif @@ -6797,42 +6742,40 @@ SUBROUTINE DMP_mf( & !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with !limits ,since they really should be recalculated after all the other changes...: !Only overwrite vt & vq in non-stratus condition - if (cldfra_bl1d(k) < cf_thresh) then - !if ((landsea-1.5).GE.0) then ! WATER - Q1=max(Q1,-2.25) - !else - ! Q1=max(Q1,-2.0) - !endif - - if (Q1 .ge. 1.0) then - Fng = 1.0 - elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then - Fng = EXP(-0.4*(Q1-1.0)) - elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - else - Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - endif - - !link the buoyancy flux function to active clouds only (c*Aup): - vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. - vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then + Fng = 1.0 + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then + Fng = EXP(-0.4*(Q1-1.0)) + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) endif - endif + + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif !check for (qc in plume) .and. (cldfra_bl < threshold) enddo !k-loop - ENDIF !end nup2 > 0 +ENDIF !end nup2 > 0 - !modify output (negative: dry plume, positive: moist plume) - IF (ktop > 0) THEN - maxqc = maxval(edmf_qc(1:ktop)) - IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf - ENDIF +!modify output (negative: dry plume, positive: moist plume) +if (ktop > 0) then + maxqc = maxval(edmf_qc(1:ktop)) + if ( maxqc < 1.E-8) maxmf = -1.0*maxmf +endif ! -! debugging +! debugging ! -IF (edmf_w(1) > 4.0) THEN +if (edmf_w(1) > 4.0) then ! surface values print *,'flq:',flq,' fltv:',fltv2 print *,'pblh:',pblh,' wstar:',wstar @@ -6885,12 +6828,12 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! ! zero or one condensation for edmf: calculates THV and QC ! -real,intent(in) :: QT,THL,P,zagl -real,intent(out) :: THV -real,intent(inout):: QC +real(kind_phys),intent(in) :: QT,THL,P,zagl +real(kind_phys),intent(out) :: THV +real(kind_phys),intent(inout):: QC integer :: niter,i -real :: diff,exn,t,th,qs,qcold +real(kind_phys):: diff,exn,t,th,qs,qcold ! constants used from module_model_constants.F ! p1000mb @@ -6932,7 +6875,7 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE !TH = THL + xlv/cp/EXN*QC - !THV= TH*(1. + 0.608*QT) + !THV= TH*(1. + p608*QT) !print *,'t,p,qt,qs,qc' !print *,t,p,qt,qs,qc @@ -6947,11 +6890,11 @@ subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) ! zero or one condensation for edmf: calculates THL and QC ! similar to condensation_edmf but with different inputs ! -real,intent(in) :: QT,THV,P,zagl -real,intent(out) :: THL, QC +real(kind_phys),intent(in) :: QT,THV,P,zagl +real(kind_phys),intent(out) :: THL, QC integer :: niter,i -real :: diff,exn,t,th,qs,qcold +real(kind_phys):: diff,exn,t,th,qs,qcold ! number of iterations niter=50 @@ -6996,61 +6939,68 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &qc_bl1d,cldfra_bl1d, & &rthraten ) - INTEGER, INTENT(IN) :: KTS,KTE,KPBL - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,rthraten,dz + integer, intent(in) :: KTS,KTE,KPBL + real(kind_phys), dimension(kts:kte), intent(in) :: & + U,V,TH,THL,TK,QT,QV,QC,THV,P,rho,exner,dz + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH - + real(kind_phys), dimension(kts:kte+1), intent(in) :: ZW + real(kind_phys), intent(in) :: WTHL,WQT + real(kind_phys), intent(in) :: dt,ust,pblh ! outputs - downdraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & - & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd + real(kind_phys), dimension(kts:kte), intent(out) :: & + edmf_a_dd,edmf_w_dd, & + edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) - REAL,DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & - sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 + real(kind_phys), dimension(kts:kte+1) :: & + sd_aw, sd_awthl, sd_awqt, sd_awu, & + sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d + real(kind_phys), dimension(kts:kte), intent(in) :: & + qc_bl1d, cldfra_bl1d - INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5 + integer, parameter:: ndown = 5 ! draw downdraft starting height randomly between cloud base and cloud top - INTEGER, DIMENSION(1:NDOWN) :: DD_initK - REAL , DIMENSION(1:NDOWN) :: randNum + integer, dimension(1:NDOWN) :: DD_initK + real(kind_phys), dimension(1:NDOWN) :: randNum ! downdraft properties - REAL,DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& - DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV + real(kind_phys), dimension(kts:kte+1,1:NDOWN) :: & + DOWNW,DOWNTHL,DOWNQT,DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV ! entrainment variables - REAl,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf - INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi + real(kind_phys), dimension(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf + integer, dimension(KTS+1:KTE+1,1:NDOWN) :: ENTi ! internal variables - INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase - REAL :: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & - EntEXP,EntW, Beta_dm, EntExp_M, rho_int - REAL :: jump_thetav, jump_qt, jump_thetal, & + integer :: K,I,ki, kminrad, qlTop, p700_ind, qlBase + real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT, & + sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn, & + THVk,Pk,EntEXP,EntW,beta_dm,EntExp_M,rho_int + real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT ! DD specific internal variables - REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd + real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - - REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& + real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt, & Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters - REAL,PARAMETER :: & - &Wa=1., & - &Wb=1.5,& - &Z00=100.,& - &BCOEFF=0.2 + real(kind_phys),parameter :: & + &Wa=1., Wb=1.5, Z00=100., BCOEFF=0.2 ! entrainment parameters - REAL,PARAMETER :: & - & L0=80,& - & ENT0=0.2 - + real(kind_phys),parameter :: & + &L0=80, ENT0=0.2 + !downdraft properties + real(kind_phys):: & + & dp, & !diameter of plume + & dl, & !diameter increment + & Adn !total area of downdrafts + !additional printouts for debugging + integer, parameter :: debug_mf=0 + + dl = (1000.-500.)/real(ndown) pwmin=-3. ! drawing from the negative tail -3sigma to -1sigma pwmax=-1. @@ -7109,7 +7059,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & do i=1,NDOWN ! downdraft starts somewhere between cloud base to cloud top ! the probability is equally distributed - DD_initK(i) = qlTop ! nint(randNum(i)*REAL(qlTop-qlBase)) + qlBase + DD_initK(i) = qlTop ! nint(randNum(i)*real(qlTop-qlBase)) + qlBase enddo ! LOOP RADFLUX @@ -7120,6 +7070,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & if ( radflux < 0.0 ) F0 = abs(radflux) + F0 enddo F0 = max(F0, 1.0) + + !Allow the total fractional area of the downdrafts to be proportional + !to the radiative forcing: + !for 50 W/m2, Adn = 0.10 + !for 100 W/m2, Adn = 0.15 + !for 150 W/m2, Adn = 0.20 + Adn = min( 0.05 + F0*0.001, 0.3) + !found Sc cloud and cloud not at surface, trigger downdraft if (cloudflg) then @@ -7134,14 +7092,14 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! call Poisson(1,NDOWN,kts+1,kte,ENTf,ENTi) - ! entrainent: Ent=Ent0/dz*P(dz/L0) - do i=1,NDOWN - do k=kts+1,kte -! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) - ENT(k,i) = 0.002 - ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) - enddo - enddo +! ! entrainent: Ent=Ent0/dz*P(dz/L0) +! do i=1,NDOWN +! do k=kts+1,kte +!! ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k+1)-ZW(k)) +! ENT(k,i) = 0.002 +! ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) +! enddo +! enddo !!![EW: INVJUMP] find 700mb height then subtract trpospheric lapse rate!!! p700_ind = MINLOC(ABS(p-70000),1)!p1D is 70000 @@ -7179,13 +7137,15 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & do I=1,NDOWN !downdraft now starts at different height ki = DD_initK(I) - wlv=wmin+(wmax-wmin)/REAL(NDOWN)*(i-1) - wtv=wmin+(wmax-wmin)/REAL(NDOWN)*i + wlv=wmin+(wmax-wmin)/real(NDOWN)*(i-1) + wtv=wmin+(wmax-wmin)/real(NDOWN)*i !DOWNW(ki,I)=0.5*(wlv+wtv) DOWNW(ki,I)=wlv + !multiply downa by cloud fraction, so it's impact will diminish if + !clouds are mixed away over the course of the longer radiation time step !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - DOWNA(ki,I)=.1/REAL(NDOWN) + DOWNA(ki,I)=Adn/real(NDOWN) DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) @@ -7212,16 +7172,21 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & enddo - !print*, " Begin integration of downdrafts:" DO I=1,NDOWN + dp = 500. + dl*real(I) ! diameter of plume (meters) !print *, "Plume # =", I,"=======================" DO k=DD_initK(I)-1,KTS+1,-1 + + !Entrainment from Tian and Kuang (2016), with constraints + wmin = 0.3 + dp*0.0005 + ENT(k,i) = 0.33/(MIN(MAX(-1.0*DOWNW(k+1,I),wmin),0.9)*dp) + !starting at the first interface level below cloud top !EntExp=exp(-ENT(K,I)*dz(k)) !EntExp_M=exp(-ENT(K,I)/3.*dz(k)) - EntExp =ENT(K,I)*dz(k) - EntExp_M=ENT(K,I)*0.333*dz(k) + EntExp =ENT(K,I)*dz(k) !for all scalars + EntExp_M=ENT(K,I)*0.333*dz(k) !test for momentum QTn =DOWNQT(k+1,I) *(1.-EntExp) + QT(k)*EntExp THLn=DOWNTHL(k+1,I)*(1.-EntExp) + THL(k)*EntExp @@ -7255,11 +7220,11 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & BCOEFF*B/mindownw)*MIN(dz(k), 250.) !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. - !Add max increase of 2.0 m/s for coarse vertical resolution. - IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0))THEN - Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., 2.0) + !Add max acceleration of -2.0 m/s for coarse vertical resolution. + IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0) ENDIF - !Add symmetrical max decrease in w + !Add symmetrical max decrease in velocity (less negative) IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0) ENDIF @@ -7305,7 +7270,6 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & ! Even though downdraft starts at different height, average all up to qlTop DO k=qlTop,KTS,-1 DO I=1,NDOWN - IF (I > NDOWN) exit edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) @@ -7355,9 +7319,9 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL,INTENT(IN) :: dx,PBL1 - REAL, INTENT(OUT) :: Psig_bl,Psig_shcu - REAL :: dxdh + real(kind_phys), intent(in) :: dx,pbl1 + real(kind_phys), intent(out) :: Psig_bl,Psig_shcu + real(kind_phys) :: dxdh Psig_bl=1.0 Psig_shcu=1.0 @@ -7429,22 +7393,42 @@ FUNCTION esat_blend(t) IMPLICIT NONE - REAL, INTENT(IN):: t - REAL :: esat_blend,XC,ESL,ESI,chi - - XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common - -! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, -! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting + real(kind_phys), intent(in):: t + real(kind_phys):: esat_blend,XC,ESL,ESI,chi + !liquid + real(kind_phys), parameter:: J0= .611583699E03 + real(kind_phys), parameter:: J1= .444606896E02 + real(kind_phys), parameter:: J2= .143177157E01 + real(kind_phys), parameter:: J3= .264224321E-1 + real(kind_phys), parameter:: J4= .299291081E-3 + real(kind_phys), parameter:: J5= .203154182E-5 + real(kind_phys), parameter:: J6= .702620698E-8 + real(kind_phys), parameter:: J7= .379534310E-11 + real(kind_phys), parameter:: J8=-.321582393E-13 + !ice + real(kind_phys), parameter:: K0= .609868993E03 + real(kind_phys), parameter:: K1= .499320233E02 + real(kind_phys), parameter:: K2= .184672631E01 + real(kind_phys), parameter:: K3= .402737184E-1 + real(kind_phys), parameter:: K4= .565392987E-3 + real(kind_phys), parameter:: K5= .521693933E-5 + real(kind_phys), parameter:: K6= .307839583E-7 + real(kind_phys), parameter:: K7= .105785160E-9 + real(kind_phys), parameter:: K8= .161444444E-12 + + XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 + +! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature, +! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting ! values are returned from the function. - IF (t .GE. t0c) THEN + IF (t .GE. (t0c-6.)) THEN esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ELSE IF (t .LE. tice) THEN esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = (t0c - t)/(t0c - tice) + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + chi = ((t0c-6.) - t)/((t0c-6.) - tice) esat_blend = (1.-chi)*ESL + chi*ESI END IF @@ -7454,39 +7438,54 @@ END FUNCTION esat_blend !>\ingroup gsd_mynn_edmf !! This function extends function "esat" and returns a "blended" -!! saturation mixing ratio. +!! saturation mixing ratio. Tice currently set to 240 K, t0c = 273.15 K. !!\author JAYMES - FUNCTION qsat_blend(t, P, waterice) + FUNCTION qsat_blend(t, P) IMPLICIT NONE - REAL, INTENT(IN):: t, P - CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice - CHARACTER(LEN=1) :: wrt - REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi - - IF ( .NOT. PRESENT(waterice) ) THEN - wrt = 'b' - ELSE - wrt = waterice - ENDIF + real(kind_phys), intent(in):: t, P + real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi + !liquid + real(kind_phys), parameter:: J0= .611583699E03 + real(kind_phys), parameter:: J1= .444606896E02 + real(kind_phys), parameter:: J2= .143177157E01 + real(kind_phys), parameter:: J3= .264224321E-1 + real(kind_phys), parameter:: J4= .299291081E-3 + real(kind_phys), parameter:: J5= .203154182E-5 + real(kind_phys), parameter:: J6= .702620698E-8 + real(kind_phys), parameter:: J7= .379534310E-11 + real(kind_phys), parameter:: J8=-.321582393E-13 + !ice + real(kind_phys), parameter:: K0= .609868993E03 + real(kind_phys), parameter:: K1= .499320233E02 + real(kind_phys), parameter:: K2= .184672631E01 + real(kind_phys), parameter:: K3= .402737184E-1 + real(kind_phys), parameter:: K4= .565392987E-3 + real(kind_phys), parameter:: K5= .521693933E-5 + real(kind_phys), parameter:: K6= .307839583E-7 + real(kind_phys), parameter:: K7= .105785160E-9 + real(kind_phys), parameter:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) - IF ((t .GE. t0c) .OR. (wrt .EQ. 'w')) THEN - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + IF (t .GE. (t0c-6.)) THEN + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESL = min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. qsat_blend = 0.622*ESL/max(P-ESL, 1e-5) -! ELSE IF (t .LE. 253.) THEN ELSE IF (t .LE. tice) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ESI = min(ESI, P*0.15) qsat_blend = 0.622*ESI/max(P-ESI, 1e-5) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESL = min(ESL, P*0.15) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ESI = min(ESI, P*0.15) RSLF = 0.622*ESL/max(P-ESL, 1e-5) RSIF = 0.622*ESI/max(P-ESI, 1e-5) -! chi = (273.16-t)/20.16 - chi = (t0c - t)/(t0c - tice) +! chi = (268.16-t)/(268.16-240.) + chi = ((t0c-6.) - t)/((t0c-6.) - tice) qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF @@ -7503,8 +7502,8 @@ FUNCTION xl_blend(t) IMPLICIT NONE - REAL, INTENT(IN):: t - REAL :: xl_blend,xlvt,xlst,chi + real(kind_phys), intent(in):: t + real(kind_phys):: xl_blend,xlvt,xlst,chi !note: t0c = 273.15, tice is set in mynn_common IF (t .GE. t0c) THEN @@ -7514,7 +7513,7 @@ FUNCTION xl_blend(t) ELSE xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition -! chi = (273.16-t)/20.16 +! chi = (273.16-t)/(273.16-240.) chi = (t0c - t)/(t0c - tice) xl_blend = (1.-chi)*xlvt + chi*xlst !blended END IF @@ -7532,12 +7531,12 @@ FUNCTION phim(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - REAL, INTENT(IN):: zet - REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - REAL, PARAMETER :: am_unst=10., ah_unst=34. - REAL :: phi_m,phim + real(kind_phys), intent(in):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. + real(kind_phys):: phi_m,phim if ( zet >= 0.0 ) then dummy_0=1+zet**bm_st @@ -7553,8 +7552,8 @@ FUNCTION phim(zet) dummy_0=(1.-am_unst*zet) ! parentesis arg dummy_1=dummy_0**0.333333 ! y dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet - dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f - dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet + dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f + dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet dummy_3 = 0.57735*(2.*dummy_1+1.) ! g dummy_33 = 1.1547*dummy_11 ! dg/dzet dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic @@ -7584,12 +7583,12 @@ FUNCTION phih(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - REAL, INTENT(IN):: zet - REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - REAL, PARAMETER :: am_unst=10., ah_unst=34. - REAL :: phh,phih + real(kind_phys), intent(in):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. + real(kind_phys):: phh,phih if ( zet >= 0.0 ) then dummy_0=1+zet**bh_st @@ -7605,8 +7604,8 @@ FUNCTION phih(zet) dummy_0=(1.-ah_unst*zet) ! parentesis arg dummy_1=dummy_0**0.333333 ! y dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet - dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f - dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet + dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f + dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet dummy_3 = 0.57735*(2.*dummy_1+1.) ! g dummy_33 = 1.1547*dummy_11 ! dg/dzet dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic @@ -7623,27 +7622,30 @@ FUNCTION phih(zet) END FUNCTION phih ! ================================================================== - SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & + SUBROUTINE topdown_cloudrad(kts,kte, & + &dz1,zw,fltv,xland,kpbl,PBLH, & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & &cldfra_bl1D,rthraten, & &maxKHtopdown,KHtopdown,TKEprodTD ) !input - integer, intent(in) :: kte,kts - real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten - real, dimension(kts:kte+1), intent(in) :: zw - real, intent(in) :: pblh,xland - integer,intent(in) :: kpbl + integer, intent(in) :: kte,kts + real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: pblh,fltv + real(kind_phys), intent(in) :: xland + integer , intent(in) :: kpbl !output - real, intent(out) :: maxKHtopdown - real, dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD + real(kind_phys), intent(out) :: maxKHtopdown + real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD !local - real, dimension(kts:kte) :: zfac,wscalek2,zfacent - real :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 - real :: temps,templ,zl1,wstar3_2 - real :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad - real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent + real(kind_phys) :: bfx0,wm3,bfxpbl,dthvx,tmp1 + real(kind_phys) :: temps,templ,zl1,wstar3_2 + real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 integer :: k,kk,kminrad logical :: cloudflg @@ -7704,15 +7706,14 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & bfx0 = max(radsum/rho1(k)/cp,0.) else ! LAND radsum=MIN(0.25*radsum,30.0)!practically turn off over land - bfx0 = max(radsum/rho1(k)/cp - max(sflux,0.0),0.) + bfx0 = max(radsum/rho1(k)/cp - max(fltv,0.0),0.) endif !entrainment from PBL top thermals wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) - wm2 = wm2 + wm3**h2 bfxpbl = - ent_eff * bfx0 dthvx = max(thetav(k+1)-thetav(k),0.1) - we = max(bfxpbl/dthvx,-sqrt(wm3**h2)) + we = max(bfxpbl/dthvx,-sqrt(wm3**twothirds)) DO kk = kts,kpbl+3 !Analytic vertical profile @@ -7720,7 +7721,7 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 !Calculate an eddy diffusivity profile (not used at the moment) - wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**h1 + wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**onethird !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0 KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac KHtopdown(kk) = MAX(KHtopdown(kk),0.0) diff --git a/phys/module_bl_mynn_common.F b/phys/module_bl_mynn_common.F index 30e212454e..7d4057b27a 100644 --- a/phys/module_bl_mynn_common.F +++ b/phys/module_bl_mynn_common.F @@ -16,9 +16,9 @@ module module_bl_mynn_common ! For MPAS: ! use mpas_kind_types,only: kind_phys => RKIND ! For CCPP: -! use machine, only : kind_phys + use ccpp_kind_types, only : kind_phys ! For WRF - use module_gfs_machine, only : kind_phys +! use module_gfs_machine, only : kind_phys !WRF CONSTANTS use module_model_constants, only: & @@ -57,31 +57,35 @@ module module_bl_mynn_common ! real:: rvovrd != r_v/r_d != 1.608 ! Specified locally - real,parameter:: zero = 0.0 - real,parameter:: half = 0.5 - real,parameter:: one = 1.0 - real,parameter:: two = 2.0 - real,parameter:: onethird = 1./3. - real,parameter:: twothirds = 2./3. - real,parameter:: tref = 300.0 ! reference temperature (K) - real,parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) -! real,parameter:: p1000mb=100000.0 -! real,parameter:: svp1 = 0.6112 !(kPa) -! real,parameter:: svp2 = 17.67 !(dimensionless) -! real,parameter:: svp3 = 29.65 !(K) - real,parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice - real,parameter:: grav = g - real,parameter:: t0c = svpt0 != 273.15 +! Define single & double precision + integer, parameter :: sp = selected_real_kind(6, 37) + integer, parameter :: dp = selected_real_kind(15, 307) +! integer, parameter :: kind_phys = sp + real(kind_phys),parameter:: zero = 0.0 + real(kind_phys),parameter:: half = 0.5 + real(kind_phys),parameter:: one = 1.0 + real(kind_phys),parameter:: two = 2.0 + real(kind_phys),parameter:: onethird = 1./3. + real(kind_phys),parameter:: twothirds = 2./3. + real(kind_phys),parameter:: tref = 300.0 ! reference temperature (K) + real(kind_phys),parameter:: TKmin = 253.0 ! for total water conversion, Tripoli and Cotton (1981) +! real(kind_phys),parameter:: p1000mb=100000.0 +! real(kind_phys),parameter:: svp1 = 0.6112 !(kPa) +! real(kind_phys),parameter:: svp2 = 17.67 !(dimensionless) +! real(kind_phys),parameter:: svp3 = 29.65 !(K) + real(kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice + real(kind_phys),parameter:: grav = g + real(kind_phys),parameter:: t0c = svpt0 != 273.15 ! To be derived in the init routine - real,parameter:: ep_3 = 1.-ep_2 != 0.378 - real,parameter:: gtr = grav/tref - real,parameter:: rk = cp/r_d - real,parameter:: tv0 = p608*tref - real,parameter:: tv1 = (1.+p608)*tref - real,parameter:: xlscp = (xlv+xlf)/cp - real,parameter:: xlvcp = xlv/cp - real,parameter:: g_inv = 1./grav + real(kind_phys),parameter:: ep_3 = 1.-ep_2 != 0.378 + real(kind_phys),parameter:: gtr = grav/tref + real(kind_phys),parameter:: rk = cp/r_d + real(kind_phys),parameter:: tv0 = p608*tref + real(kind_phys),parameter:: tv1 = (1.+p608)*tref + real(kind_phys),parameter:: xlscp = (xlv+xlf)/cp + real(kind_phys),parameter:: xlvcp = xlv/cp + real(kind_phys),parameter:: g_inv = 1./grav ! grav = g ! t0c = svpt0 != 273.15 @@ -94,5 +98,4 @@ module module_bl_mynn_common ! xlvcp = xlv/cp ! g_inv = 1./grav - end module module_bl_mynn_common diff --git a/phys/module_bl_mynn_wrapper.F b/phys/module_bl_mynn_wrapper.F index 8ceccab5ac..72ce6dbaaa 100644 --- a/phys/module_bl_mynn_wrapper.F +++ b/phys/module_bl_mynn_wrapper.F @@ -73,7 +73,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & initflag,restart,cycling, & & delt,dz,dxc,znt, & & u,v,w,th, & - & qv,qc,qi,qnc,qni,qnwfa,qnifa,qnbca, & + & qv,qc,qi,qs,qnc,qni,qnwfa,qnifa,qnbca, & ! & ozone, & & p,exner,rho,t3d, & & xland,ts,qsfc,ps, & @@ -89,7 +89,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !--- end chem/smoke & Tsq,Qsq,Cov, & & rublten,rvblten,rthblten, & - & rqvblten,rqcblten,rqiblten, & + & rqvblten,rqcblten,rqiblten,rqsblten, & & rqncblten,rqniblten, & & rqnwfablten,rqnifablten,rqnbcablten, & ! & ro3blten, & @@ -100,7 +100,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & edmf_thl,edmf_ent,edmf_qc, & & sub_thl3d,sub_sqv3d, & & det_thl3d,det_sqv3d, & - & nupdraft,maxMF,ktop_plume, & + & maxwidth,maxMF,ztop_plume,ktop_plume, & & rthraten, & & tke_budget, bl_mynn_tkeadvect, & & bl_mynn_cloudpdf, bl_mynn_mixlength, & @@ -110,14 +110,13 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_output, bl_mynn_closure, & & bl_mynn_mixscalars, & & spp_pbl,pattern_spp_pbl, & - & flag_qc,flag_qi, & + & flag_qc,flag_qi,flag_qs, & & flag_qnc,flag_qni, & & flag_qnwfa,flag_qnifa,flag_qnbca, & & ids,ide,jds,jde,kds,kde, & & ims,ime,jms,jme,kms,kme, & & its,ite,jts,jte,kts,kte ) -! use module_gfs_machine, only : kind_phys use module_bl_mynn, only: mynn_bl_driver !------------------------------------------------------------------- @@ -161,16 +160,16 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_mixscalars, & & spp_pbl, & & tke_budget - real, intent(in) :: & + real(kind_phys), intent(in) :: & & bl_mynn_closure logical, intent(in) :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QNWFA, FLAG_QNIFA, FLAG_QNBCA + & FLAG_QS, FLAG_QNWFA, FLAG_QNIFA, FLAG_QNBCA logical, parameter :: FLAG_OZONE = .false. !MYNN-1D - REAL, intent(in) :: delt, dxc + REAL(kind_phys), intent(in) :: delt, dxc LOGICAL, intent(in) :: restart INTEGER :: i, j, k, itf, jtf, ktf, n INTEGER, intent(in) :: initflag, & @@ -179,72 +178,72 @@ SUBROUTINE mynnedmf_wrapper_run( & & ITS,ITE,JTS,JTE,KTS,KTE !MYNN-3D - real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(in) :: & & u,v,w,t3d,th,rho,exner,p,dz - real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & - & rublten,rvblten,rthblten, & - & rqvblten,rqcblten,rqiblten, & - & rqncblten,rqniblten, & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & + & rublten,rvblten,rthblten, & + & rqvblten,rqcblten,rqiblten,rqsblten, & + & rqncblten,rqniblten, & & rqnwfablten,rqnifablten,rqnbcablten !,ro3blten - real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & & qke, qke_adv, el_pbl, sh3d, sm3d - real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: & & Tsq, Qsq, Cov, exch_h, exch_m - real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: rthraten + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), intent(in) :: rthraten !optional 3D arrays - real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(in) :: & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(in) :: & & pattern_spp_pbl - real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & & qc_bl, qi_bl, cldfra_bl - real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & edmf_a,edmf_w,edmf_qt, & - & edmf_thl,edmf_ent,edmf_qc, & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & + & edmf_a,edmf_w,edmf_qt, & + & edmf_thl,edmf_ent,edmf_qc, & & sub_thl3d,sub_sqv3d,det_thl3d,det_sqv3d - real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & & dqke,qWT,qSHEAR,qBUOY,qDISS - real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & - & qv,qc,qi,qnc,qni,qnwfa,qnifa,qnbca!,o3 + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme), optional, intent(inout) :: & + & qv,qc,qi,qs,qnc,qni,qnwfa,qnifa,qnbca!,o3 !optional 2D arrays for passing into module_bl_myn.F - real, allocatable, dimension(:,:) :: & + real(kind_phys), allocatable, dimension(:,:) :: & & qc_bl2d, qi_bl2d, cldfra_bl2d, pattern_spp_pbl2d - real, allocatable, dimension(:,:) :: & - & edmf_a2d,edmf_w2d,edmf_qt2d, & - & edmf_thl2d,edmf_ent2d,edmf_qc2d, & + real(kind_phys), allocatable, dimension(:,:) :: & + & edmf_a2d,edmf_w2d,edmf_qt2d, & + & edmf_thl2d,edmf_ent2d,edmf_qc2d, & & sub_thl2d,sub_sqv2d,det_thl2d,det_sqv2d - real, allocatable, dimension(:,:) :: & + real(kind_phys), allocatable, dimension(:,:) :: & & dqke2d,qWT2d,qSHEAR2d,qBUOY2d,qDISS2d - real, allocatable, dimension(:,:) :: & - & qc2d,qi2d,qnc2d,qni2d,qnwfa2d,qnifa2d,qnbca2d!,o32d + real(kind_phys), allocatable, dimension(:,:) :: & + & qc2d,qi2d,qs2d,qnc2d,qni2d,qnwfa2d,qnifa2d,qnbca2d!,o32d !smoke/chem arrays - no if-defs in module_bl_mynn.F, so must define arrays #if (WRF_CHEM == 1) - real, dimension(ims:ime,kms:kme,jms:jme,nchem), intent(in) :: chem3d - real, dimension(ims:ime,kdvel,jms:jme, ndvel), intent(in) :: vd3d - real, dimension(ims:ime,kms:kme,nchem) :: chem - real, dimension(ims:ime,ndvel) :: vd - real, dimension(ims:ime) :: frp_mean, emis_ant_no + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme,nchem), intent(in) :: chem3d + real(kind_phys), dimension(ims:ime,kdvel,jms:jme, ndvel), intent(in) :: vd3d + real(kind_phys), dimension(ims:ime,kms:kme,nchem) :: chem + real(kind_phys), dimension(ims:ime,ndvel) :: vd + real(kind_phys), dimension(ims:ime) :: frp_mean, emis_ant_no #else - real, dimension(ims:ime,kms:kme,nchem) :: chem - real, dimension(ims:ime,ndvel) :: vd - real, dimension(ims:ime) :: frp_mean, emis_ant_no + real(kind_phys), dimension(ims:ime,kms:kme,nchem) :: chem + real(kind_phys), dimension(ims:ime,ndvel) :: vd + real(kind_phys), dimension(ims:ime) :: frp_mean, emis_ant_no #endif !MYNN-2D - real, dimension(ims:ime,jms:jme), intent(in) :: & + real(kind_phys), dimension(ims:ime,jms:jme), intent(in) :: & & xland,ts,qsfc,ps,ch - real, dimension(ims:ime,jms:jme), intent(inout) :: & - & znt,pblh,maxmf,rmol,hfx,qfx,ust,wspd, & + real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: & + & znt,pblh,maxwidth,maxmf,ztop_plume,rmol,hfx,qfx,ust,wspd, & & uoce,voce - integer, dimension(ims:ime,jms:jme), intent(inout) :: & - & kpbl,nupdraft,ktop_plume + integer, dimension(ims:ime,jms:jme), intent(inout) :: & + & kpbl,ktop_plume !Local - real, dimension(ims:ime,kms:kme) :: delp,sqv,sqc,sqi - real, dimension(ims:ime) :: dx - logical, parameter :: debug = .false. - real, dimension(ims:ime,kms:kme,jms:jme) :: ozone,r03blten + real(kind_phys), dimension(ims:ime,kms:kme) :: delp,sqv,sqc,sqi,sqs,ikzero + real(kind_phys), dimension(ims:ime) :: dx + logical, parameter :: debug = .false. + real(kind_phys), dimension(ims:ime,kms:kme,jms:jme) :: ozone,rO3blten !write(0,*)"==============================================" !write(0,*)"in mynn wrapper..." @@ -257,7 +256,8 @@ SUBROUTINE mynnedmf_wrapper_run( & !For now, initialized bogus array ozone=0.0 - r03blten=0.0 + rO3blten=0.0 + ikzero=0.0 !Allocate any arrays being used if (icloud_bl > 0) then @@ -303,6 +303,10 @@ SUBROUTINE mynnedmf_wrapper_run( & allocate(qi2d(ims:ime,kms:kme)) qi2d=0.0 endif + if (flag_qs) then + allocate(qs2d(ims:ime,kms:kme)) + qs2d=0.0 + endif if (flag_qnc) then allocate(qnc2d(ims:ime,kms:kme)) qnc2d=0.0 @@ -363,6 +367,13 @@ SUBROUTINE mynnedmf_wrapper_run( & enddo enddo endif + if (flag_qs) then + do k=kts,ktf + do i=its,itf + qs2d(i,k) = qs(i,k,j) + enddo + enddo + endif if (flag_qnc) then do k=kts,ktf do i=its,itf @@ -429,12 +440,6 @@ SUBROUTINE mynnedmf_wrapper_run( & ! First, create pressure differences (delp) across model layers do i=its,itf dx(i)=dxc -! delp(i,1) = ps(i,j) - (p(i,2,j)*dz(i,1,j) + p(i,1,j)*dz(i,2,j))/(dz(i,1,j)+dz(i,2,j)) -! do k=2,kte-1 -! delp(i,k) = (p(i,k,j)*dz(i,k-1,j) + p(i,k-1,j)*dz(i,k,j))/(dz(i,k,j)+dz(i,k-1,j)) - & -! (p(i,k+1,j)*dz(i,k,j) + p(i,k,j)*dz(i,k+1,j))/(dz(i,k,j)+dz(i,k+1,j)) -! enddo -! delp(i,kte) = delp(i,kte-1) enddo ! do i=its,itf @@ -445,17 +450,30 @@ SUBROUTINE mynnedmf_wrapper_run( & ! enddo !In WRF, mixing ratio is incoming. Convert to specific humidity: - do k=kts,ktf - do i=its,itf + do k=kts,ktf + do i=its,itf sqv(i,k)=qv(i,k,j)/(1.0 + qv(i,k,j)) sqc(i,k)=qc2d(i,k)/(1.0 + qv(i,k,j)) - sqi(i,k)=qi2d(i,k)/(1.0 + qv(i,k,j)) enddo enddo - -! do i=its,ite -! ts(i,j)=tsurf(i,j)/exner(i,1,j) !theta -! enddo + if (flag_qi) then + do k=kts,ktf + do i=its,itf + sqi(i,k)=qi2d(i,k)/(1.0 + qv(i,k,j)) + enddo + enddo + else + sqi(:,:)=0.0 + endif + if (flag_qs) then + do k=kts,ktf + do i=its,itf + sqs(i,k)=qs2d(i,k)/(1.0 + qv(i,k,j)) + enddo + enddo + else + sqs(:,:)=0.0 + endif if (debug) then print* @@ -503,8 +521,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & delt=delt,dz=dz(:,:,j),dx=dx,znt=znt(:,j), & & u=u(:,:,j),v=v(:,:,j),w=w(:,:,j), & & th=th(:,:,j),sqv3D=sqv,sqc3D=sqc, & - & sqi3D=sqi,qnc=qnc2d,qni=qni2d, & - & qnwfa=qnwfa2d,qnifa=qnifa2d, & + & sqi3D=sqi,sqs3D=sqs,qnc=qnc2d,qni=qni2d, & + & qnwfa=qnwfa2d,qnifa=qnifa2d,qnbca=qnbca2d, & & ozone=ozone(:,:,j), & & p=p(:,:,j),exner=exner(:,:,j),rho=rho(:,:,j), & & T3D=t3d(:,:,j),xland=xland(:,j), & @@ -524,10 +542,11 @@ SUBROUTINE mynnedmf_wrapper_run( & & RTHBLTEN=RTHBLTEN(:,:,j),RQVBLTEN=RQVBLTEN(:,:,j), & !output & RQCBLTEN=rqcblten(:,:,j),RQIBLTEN=rqiblten(:,:,j), & !output & RQNCBLTEN=rqncblten(:,:,j),RQNIBLTEN=rqniblten(:,:,j), & !output + & RQSBLTEN=ikzero, & !there is no RQSBLTEN, so use dummy arary & RQNWFABLTEN=RQNWFABLTEN(:,:,j), & !output & RQNIFABLTEN=RQNIFABLTEN(:,:,j), & !output & RQNBCABLTEN=RQNBCABLTEN(:,:,j), & !output - & dozone=r03blten(:,:,j), & !output + & dozone=rO3blten(:,:,j), & !output & EXCH_H=exch_h(:,:,j),EXCH_M=exch_m(:,:,j), & !output & pblh=pblh(:,j),KPBL=KPBL(:,j), & !output & el_pbl=el_pbl(:,:,j), & !output @@ -551,14 +570,14 @@ SUBROUTINE mynnedmf_wrapper_run( & & edmf_ent=edmf_ent2d,edmf_qc=edmf_qc2d, & !output & sub_thl3D=sub_thl2d,sub_sqv3D=sub_sqv2d, & !output & det_thl3D=det_thl2d,det_sqv3D=det_sqv2d, & !output - & nupdraft=nupdraft(:,j),maxMF=maxMF(:,j), & !output - & ktop_plume=ktop_plume(:,j), & !output + & maxwidth=maxwidth(:,j),maxMF=maxMF(:,j), & !output + & ztop_plume=ztop_plume(:,j),ktop_plume=ktop_plume(:,j), & !output & spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl2d, & !input & RTHRATEN=rthraten(:,:,j), & !input - & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input + & FLAG_QI=flag_qi,FLAG_QNI=flag_qni,FLAG_QS=flag_qs, & !input & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input - & FLAG_QNBCA=FLAG_QNBCA, & !input + & FLAG_QNBCA=FLAG_QNBCA,FLAG_OZONE=flag_ozone, & !input & IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde, & !input & IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme, & !input & ITS=its,ITE=itf,JTS=jts,JTE=jtf,KTS=kts,KTE=kte) !input @@ -572,13 +591,20 @@ SUBROUTINE mynnedmf_wrapper_run( & RQIBLTEN(i,k,j) = RQIBLTEN(i,k,j)/(1.0 - sqv(i,k)) enddo enddo + if (.false.) then !as of now, there is no RQSBLTEN in WRF + do k=kts,ktf + do i=its,itf + RQSBLTEN(i,k,j) = RQSBLTEN(i,k,j)/(1.0 - sqv(i,k)) + enddo + enddo + endif !- Collect 3D ouput: if (icloud_bl > 0) then do k=kts,ktf do i=its,itf - qc_bl(i,k,j) = qc_bl2d(i,k) - qi_bl(i,k,j) = qi_bl2d(i,k) + qc_bl(i,k,j) = qc_bl2d(i,k)/(1.0 - sqv(i,k)) + qi_bl(i,k,j) = qi_bl2d(i,k)/(1.0 - sqv(i,k)) cldfra_bl(i,k,j) = cldfra_bl2d(i,k) enddo enddo @@ -648,8 +674,7 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"dudt:",rublten(its,1,j),rublten(its,2,j),rublten(its,kte,j) print*,"dvdt:",rvblten(its,1,j),rvblten(its,2,j),rvblten(its,kte,j) print*,"dqdt:",rqvblten(its,1,j),rqvblten(its,2,j),rqvblten(its,kte,j) - print*,"ktop_plume:",ktop_plume(its,j)," maxmf:",maxmf(its,j) - print*,"nup:",nupdraft(its,j) + print*,"ztop_plume:",ztop_plume(its,j)," maxmf:",maxmf(its,j) print* endif @@ -682,6 +707,7 @@ SUBROUTINE mynnedmf_wrapper_run( & endif if (flag_qc) deallocate(qc2d) if (flag_qi) deallocate(qi2d) + if (flag_qs) deallocate(qs2d) if (flag_qnc) deallocate(qnc2d) if (flag_qni) deallocate(qni2d) if (flag_qnwfa)deallocate(qnwfa2d) diff --git a/phys/module_bl_ysu.F b/phys/module_bl_ysu.F index b2584eaa96..403532e094 100644 --- a/phys/module_bl_ysu.F +++ b/phys/module_bl_ysu.F @@ -1,23 +1,22 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 !================================================================================================================= -!module_bl_ysu.F was modified to accomodate both the WRF and MPAS models / 2018-12-7 + module module_bl_ysu + use ccpp_kind_types,only: kind_phys + use bl_ysu + + + implicit none + private + public:: ysu + + + contains + + !================================================================================================================= -!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, & znt,ust,hpbl,psim,psih, & @@ -39,11 +38,10 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - !optional - regime & + 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) @@ -97,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 @@ -115,27 +130,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile -!-- 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 !------------------------------------------------------------------------------- ! - integer,parameter :: ndiff = 3 - real,parameter :: rcl = 1.0 ! integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -143,70 +139,76 @@ 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(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: exch_h, & exch_m - 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, 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 - integer, intent(in) :: idiff - logical, intent(in) :: flag_bep - real,dimension(ims:ime,kms:kme,jms:jme),intent(in) :: a_u_bep, & +! + logical, intent(in) :: flag_qc, & + flag_qi +! + integer, intent(in) :: idiff + logical, intent(in) :: flag_bep + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + optional , & + intent(in) :: a_u_bep, & a_v_bep,a_t_bep, & a_e_bep,b_u_bep, & a_q_bep,b_q_bep, & @@ -214,1700 +216,263 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & b_e_bep,dlg_bep, & dl_u_bep, & vl_bep,sf_bep - real, dimension(ims:ime,jms:jme),intent(in) :: frc_urb2d -! -!optional -! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(inout) :: regime -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension(ims:ime,jms:jme) , & optional , & - intent(inout) :: rqiblten + 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 - real,dimension(its:ite,kts:kte,jts:jte) :: a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e, & - a_q,b_q,dlg,dl_u,sfk,vlk - real,dimension(its:ite,jts:jte) :: frcurb - real :: bepswitch ! 0 if not using bep or bep+bem, 1 if using -! - qv2d(its:ite,:) = 0.0 -! - bepswitch = 0.0 - a_u(:,:,:)=0.0 - a_v(:,:,:)=0.0 - a_t(:,:,:)=0.0 - a_q(:,:,:)=0.0 - a_e(:,:,:)=0.0 - b_u(:,:,:)=0.0 - b_v(:,:,:)=0.0 - b_t(:,:,:)=0.0 - b_q(:,:,:)=0.0 - b_e(:,:,:)=0.0 - sfk(:,:,:)=1.0 - vlk(:,:,:)=1.0 - dl_u(:,:,:)=0.0 - dlg(:,:,:)=0.0 - frcurb(:,:)=0.0 - do j = jts,jte - 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 +!temporary allocation of local chemical species and/or passive tracers that are vertically- +!mixed in subroutine bl_ysu_run: + logical:: l_topdown_pblmix - do k = kts,kte - do i = its,ite - qv2d(i,k) = qv3d(i,k,j) - qv2d(i,k+kte) = qc3d(i,k,j) - if(flag_qi) qv2d(i,k+kte+kte) = qi3d(i,k,j) - enddo - enddo + integer, parameter :: nmix = 0 + integer :: n - if(flag_bep) then - bepswitch=1.0 - do k=kts,kte - do i=its,ite - a_u(i,k,j)=a_u_bep(i,k,j) - a_v(i,k,j)=a_v_bep(i,k,j) - a_t(i,k,j)=a_t_bep(i,k,j) - a_q(i,k,j)=a_q_bep(i,k,j) - a_e(i,k,j)=a_e_bep(i,k,j) - b_u(i,k,j)=b_u_bep(i,k,j) - b_v(i,k,j)=b_v_bep(i,k,j) - b_t(i,k,j)=b_t_bep(i,k,j) - b_q(i,k,j)=b_q_bep(i,k,j) - b_e(i,k,j)=b_e_bep(i,k,j) - sfk(i,k,j)=sf_bep(i,k,j) - vlk(i,k,j)=vl_bep(i,k,j) - dl_u(i,k,j)=dl_u_bep(i,k,j) - dlg(i,k,j)=dlg_bep(i,k,j) - frcurb(i,j)=frc_urb2d(i,j) - enddo - enddo - endif -! - 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) & - ,exch_mx=exch_m(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) & - ,a_u2d=a_u(its,kts,j), a_v2d=a_v(its,kts,j) & - ,a_t2d=a_t(its,kts,j), a_q2d=a_q(its,kts,j) & - ,b_u2d=b_u(its,kts,j), b_v2d=b_v(its,kts,j) & - ,b_t2d=b_t(its,kts,j), b_q2d=b_q(its,kts,j) & - ,b_e2d=b_e(its,kts,j), a_e2d=a_e(its,kts,j) & - ,sfk2d=sfk(its,kts,j), vlk2d=vlk(its,kts,j) & - ,dlu2d=dl_u(its,kts,j), dlg2d=dlg(its,kts,j) & - ,frc_urb1d=frcurb(its,j), bepswitch=bepswitch & - ,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(flag_qi) 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,exch_mx, & - wstar,delta, & - u10,v10, & - uox,vox, & - rthraten,p2diORG, & - ysu_topdown_pblmix, & - ctopo,ctopo2, & - a_u2d, a_v2d, a_t2d, a_q2d, & - b_u2d, b_v2d, b_t2d, b_q2d, & - b_e2d, a_e2d, sfk2d, vlk2d, & - dlu2d, dlg2d, & - frc_urb1d, bepswitch, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - !optional - regime & - ) -!------------------------------------------------------------------------------- - 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 neutral, 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 psim psih are ln(z1/z0)-psim,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 -! add multilayer urban canopy models of BEP and BEP+BEM, jan 2021 -! -! references: -! -! hendricks, knievel, and wang (2020), j. appl. meteor. clim. -! 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.33333333, 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 + 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 - 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, kts:kte ), & - intent(in) :: a_u2d, & - a_v2d, & - a_t2d, & - a_q2d, & - b_u2d, & - b_v2d, & - b_t2d, & - b_q2d, & - b_e2d, & - a_e2d, & - sfk2d, & - vlk2d, & - dlu2d, & - dlg2d - - real, dimension( its:ite ), & - intent(in) :: frc_urb1d - real :: bepswitch - 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, & - ad1, adm -! -!jdf added exch_hx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: exch_hx, & - exch_mx -! - 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 - - 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 -! + ! Local tile-sized arrays for contiguous data for bl_ysu_run call. - 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,vconvlim,vconvnew,fluxc,vconvc,vconv -!topo-corr - real, dimension( ims:ime, kms:kme ) :: fric, & - tke_ysu,& - el_ysu,& - shear_ysu,& - buoy_ysu - real, dimension( ims:ime ) :: pblh_ysu,& - vconvfx -! -!------------------------------------------------------------------------------- -! - 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 -! - 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, 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.+(1.0-bepswitch)*hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*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/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - 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 -! -! add bep/bep+bem forcing for heat if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_t2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_t2d(i,k)*dt2 - 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)+(1.0-bepswitch)*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 = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*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/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - 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 -! - 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) - enddo - enddo - enddo - endif -! -! add bep/bep+bem forcing for water vapor if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_q2d(i,k)*dt2 - f3(i,k,1) = f3(i,k,1) + b_q2d(i,k)*dt2 - 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) - 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 - 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 -! -! paj: ctopo=1 if topo_wind=0 (default) -!raquel---paj tke code (could be replaced with shin-hong tke in future - do i = its,ite - do k= kts, kte-1 - shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & - + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) - buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) +!----------------------------------------------------------------------------------------------------------------- - zk = karman*zq(i,k+1) - !over pbl - if (k.ge.kpbl(i)) then - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - else - !in pbl - rlamdz = 150.0 - endif - el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) - tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)+b_e2d(i,k)) - !q2 when q3 positive - if(tke_ysu(i,k).le.0) then - tke_ysu(i,k)=0.0 - else - tke_ysu(i,k)=(tke_ysu(i,k))**0.66 - endif - enddo - !Hybrid pblh of MYNN - !tke is q2 - CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& - & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) -!--- end of paj tke -! compute vconv -! Use Beljaars over land - if (xland(i).lt.1.5) then - fluxc = max(sflux(i),0.0) - vconvc=1. - VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 - else -! for water there is no topo effect so vconv not needed - VCONV = 0. - endif - vconvfx(i) = vconv -!raquel -!ctopo stability correction - fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - if(present(ctopo)) then - vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) - vconvlim = min(vconvnew,1.0) - ad(i,1) = 1.+(1.0-bepswitch*frc_urb1d(i))* & - (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) - & - fric(i,1)*bepswitch*(1-frc_urb1d(i)) - else - ad(i,1) = 1.+(1.0-bepswitch)*fric(i,1) - endif - f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = sfk2d(i,k)*dt2/del(i,k) - dtodsu = sfk2d(i,k)*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/vlk2d(i,k) - al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_mx(i,k+1) = xkzm(i,k) - enddo - enddo -! -! add bep/bep+bem forcing for momentum if flag_bep=.true. -! - do k = kts,kte - do i = its,ite - ad1(i,k) = ad(i,k) - end do - end do - do k = kts,kte - do i = its,ite - ad(i,k) = ad(i,k) - a_u2d(i,k)*dt2 - ad1(i,k) = ad1(i,k) - a_v2d(i,k)*dt2 - f1(i,k) = f1(i,k) + b_u2d(i,k)*dt2 - f2(i,k) = f2(i,k) + b_v2d(i,k)*dt2 - 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 tridi2n(al,ad,ad1,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 -! - end subroutine ysu2d -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridi2n(cl,cm,cm1,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, & - cm1, & - 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./cm1(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo + l_topdown_pblmix = .false. + if(ysu_topdown_pblmix .eq. 1) l_topdown_pblmix = .true. - 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./(cm1(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./(cm1(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 tridi2n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - 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 - 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 + do j = jts,jte ! - end subroutine ysuinit -!------------------------------------------------------------------------------- -! ================================================================== - - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea) -! Copied from MYNN PBL - - !--------------------------------------------------------------- - ! 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. - !--------------------------------------------------------------- + ! Assign input data to local tile-sized arrays. - 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. !Theta-v PBL lower limit of trust (m). - REAL, PARAMETER :: sbl_damp = 400. !Damping range for averaging with TKE-based PBLH (m). - INTEGER :: I,J,K,kthv,ktke + 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 - !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M - k = kts+1 - kthv = 1 - ktke = 1 - maxqke = 0. - minthv = 9.E9 + do k = kts, kte+1 + do i = its, ite + p3di_hv(i,k) = p3di(i,k,j) + end do + end do - 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) - TKEeps = MIN(TKEeps,0.25) + 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 - !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.5 - ENDIF - - zi=0. - k = kthv+1 - DO WHILE (zi .EQ. 0.) - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - ENDIF - k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO + 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 + do i = its, ite + frcurb_hv(i) = frc_urb2d(i,j) + enddo + endif - !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. - !FIND TKE-BASED PBLH (BEST FOR NOCTURNAL/STABLE CONDITIONS). + 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. - 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 - 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 + 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 - !BLEND THE TWO PBLH TYPES HERE: + 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 - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - zi=PBLH_TKE*(1.-wt) + zi*wt + 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 GET_PBLH -! ================================================================== + end subroutine ysu -end module module_bl_ysu -!------------------------------------------------------------------------------- +!================================================================================================================= + end module module_bl_ysu +!================================================================================================================= diff --git a/phys/module_cu_ntiedtke.F b/phys/module_cu_ntiedtke.F index b638e6e56c..3b56132b66 100644 --- a/phys/module_cu_ntiedtke.F +++ b/phys/module_cu_ntiedtke.F @@ -1,165 +1,36 @@ -!----------------------------------------------------------------------- -! -!wrf:model_layer:physics -! -!####################tiedtke scheme######################### -! m.tiedtke e.c.m.w.f. 1989 -! j.morcrette 1992 -!-------------------------------------------- -! modifications -! C. zhang & Yuqing Wang 2011-2017 -! -! 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 -! -!=========================================================== -! Note for climate simulation of Tropical Cyclones -! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation -! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km -! Set: momtrans = 2. -! pgcoef = 0.7 to 1.0 is good depends on the basin -! nonequil = .false. -!=========================================================== -! Note for the diurnal simulation of precipitaton -! When nonequil = .true., the CAPE is relaxed toward to a value from PBL -! It can improve the diurnal precipitation over land. -!=========================================================== -!########################################################### - -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 :: t13,rcpd,vtmpc1,tmelt, & - c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg - - real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice - real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon,pgcoef - integer,private :: momtrans - - parameter( & - t13=1.0/3.0, & - 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 ) -! ------- -! -! coefficient for pressure gradient intensity -! (0.7 - 1.0 is recommended in this vesion of Tiedtke scheme) - parameter(pgcoef=0.7) -! ------- -! - logical :: nonequil -! nonequil: representing equilibrium and nonequilibrium convection -! ( .false. [equilibrium: removing all CAPE]; .true. [nonequilibrium: relaxing CAPE toward CAPE from PBL]. -! Ref. Bechtold et al. 2014 JAS ) -! - parameter(nonequil = .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 -!------------------------------------------------------------------- +!================================================================================================================= + module module_cu_ntiedtke + use ccpp_kind_types,only: kind_phys + + use cu_ntiedtke,only: cu_ntiedtke_run, & + cu_ntiedtke_init + use cu_ntiedtke_common + + implicit none + private + public:: cu_ntiedtke_driver, & + ntiedtkeinit + + + contains + + +!================================================================================================================= + 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_qv,f_qc,f_qr,f_qi,f_qs & + ,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) @@ -210,3682 +81,453 @@ 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, & - dx2d - - 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, pp -!----------------------------------------------------------------------- -! -! -!*** 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 i=its,ite - dx2d(i) = dx(i,j) - 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 - - pp = 0 - do k=kts,kte - zz = kte-pp - 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 - pp = pp + 1 - 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) = p8w(i,k,j) - enddo - pp = pp + 1 - 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,dx2d) - - do i=its,ite - raincv(i,j)=rn(i)/stepcu - pratec(i,j)=rn(i)/(stepcu * dt) - enddo - - pp = 0 - do k=kts,kte - zz = kte-pp - 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 - pp = pp + 1 - enddo - - if(present(rqccuten))then - if ( f_qc ) then - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt - enddo - pp = pp + 1 +!----------------------------------------------------------------------------------------------------------------- + +!--- input arguments: + logical,intent(in),optional:: f_qv,f_qc,f_qr,f_qi,f_qs + + 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 - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt - enddo - pp = pp + 1 + 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 - real scale_fac(lq), scale_fac2(lq), dxref -! -! set scale-dependency factor when dx is < 15 km -! - dxref = 15000. - do j=1,lq - if (dx(j).lt.dxref) then - scale_fac(j) = (1.06133+log(dxref/dx(j)))**3 - scale_fac2(j) = scale_fac(j)**0.5 - else - scale_fac(j) = 1.+1.33e-5*dx(j) - scale_fac2(j) = 1. - end if - end do -! - 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, & - & scale_fac, scale_fac2) -! -! 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, & - & scale_fac, scale_fac2) - 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) - real scale_fac(klon), scale_fac2(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) - ztauc(jl) = max(ztmst,ztauc(jl)) - ztauc(jl) = max(360.,ztauc(jl)) - ztauc(jl) = min(10800.,ztauc(jl)) - ztau = ztauc(jl) * scale_fac(jl) - if(nonequil) 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) = zmfub1(jl)/scale_fac2(jl) - 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 - - 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 - -! 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 - -! 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 - pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& - pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) - pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& - pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) - 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 - 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) -!-------------------------------------------------------------- - 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 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,-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 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.2 ) 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 ( 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 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)) - 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 * & - (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & - pmfds(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)*(pmfuq(jl,jk+1) - & - pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(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 * & - (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) - zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & - pmfdq(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) - -!local variables - real zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & - zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) - - 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 - - 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) - - return - end function foealfa - - 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 - - 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 - - real function foeldcpm(tt) - implicit none - real tt - foeldcpm = foealfa(tt)*ralvdcp+ & - & (1.-foealfa(tt))*ralsdcp - return - end function foeldcpm - -end module module_cu_ntiedtke - + endif + endif + + enddo + + end subroutine cu_ntiedtke_driver + +!================================================================================================================= + 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) +!================================================================================================================= + +!--- input arguments: + 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 + +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,rthften,rqvften + +!--- local variables and arrays: + 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 + +!================================================================================================================= + 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 + +!================================================================================================================= + 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_timestep_final OK' + errflg = 0 + + end subroutine cu_ntiedtke_post_run + +!================================================================================================================= + end module module_cu_ntiedtke +!================================================================================================================= diff --git a/phys/module_cumulus_driver.F b/phys/module_cumulus_driver.F index 305c32dde1..e1292a2d56 100644 --- a/phys/module_cumulus_driver.F +++ b/phys/module_cumulus_driver.F @@ -200,7 +200,7 @@ SUBROUTINE cumulus_driver(grid & USE module_cu_osas , ONLY : cu_osas USE module_cu_camzm_driver, ONLY : camzm_driver USE module_cu_tiedtke, ONLY : cu_tiedtke - USE module_cu_ntiedtke,ONLY : cu_ntiedtke + USE module_cu_ntiedtke,ONLY : cu_ntiedtke_driver USE module_cu_ksas , ONLY : cu_ksas USE module_cu_nsas , ONLY : cu_nsas USE module_wrf_error , ONLY : wrf_err_message @@ -744,6 +744,10 @@ SUBROUTINE cumulus_driver(grid & INTEGER, INTENT(IN) :: JULDAY #endif +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + !----------------------------------------------------------------- pattern_spp_conv=0. field_conv=0. @@ -1414,7 +1418,7 @@ SUBROUTINE cumulus_driver(grid & CASE (NTIEDTKESCHEME) CALL wrf_debug(100,'in cu_ntiedtke') - CALL CU_NTIEDTKE( & + CALL CU_NTIEDTKE_DRIVER( & DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU,HFX=hfx & ,RAINCV=RAINCV,PRATEC=tmppratec,QFX=qfx & ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & @@ -1431,6 +1435,9 @@ SUBROUTINE cumulus_driver(grid & ,RUCUTEN = RUCUTEN,RVCUTEN = RVCUTEN & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs & + ,GRAV=g,XLF=xlf,XLS=xls,XLV=xlv & + ,RD=r_d,RV=r_v,CP=cp & + ,errmsg=errmsg,errflg=errflg & ) ! New KIM SAS SCHEME - (KIAPS, South Korea) diff --git a/phys/module_diag_functions.F b/phys/module_diag_functions.F index ac920798ac..0466dff45f 100644 --- a/phys/module_diag_functions.F +++ b/phys/module_diag_functions.F @@ -760,9 +760,10 @@ FUNCTION Buoyancy ( nz, tk, rh, p, hgt, sfc, cape, cin, zlfc, plfc, lidx, & flag = .false. END IF END DO - IF (ellev >= 0) THEN !Modified by Zhixiao - pel = p(ellev) !Modified by Zhixiao - CIN=REAL ( 0 ) !Modified by Zhixiao + IF ((ellev >= 0) .and. (lfclev >= 0)) THEN !Modified by Zhixiao + plfc = p (lfclev) + pel = p (ellev) + CIN = REAL ( 0 ) DO k = sfc+1, nz ! Make CAPE and CIN consistent with AMS definition ! https://glossary.ametsoc.org/wiki/Convective_available_potential_energy diff --git a/phys/module_diag_nwp.F b/phys/module_diag_nwp.F index 9879b496a7..336b0cd372 100644 --- a/phys/module_diag_nwp.F +++ b/phys/module_diag_nwp.F @@ -13,6 +13,7 @@ MODULE module_diag_nwp PRIVATE :: GAMMLN CONTAINS SUBROUTINE diagnostic_output_nwp( & + config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -44,15 +45,17 @@ SUBROUTINE diagnostic_output_nwp( & ) !---------------------------------------------------------------------- + USE module_configure, ONLY : grid_config_rec_type + USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, THOMPSONGH, & MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & - NSSL_2MOM, NSSL_2MOMG, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & MILBRANDT2MOM , CAMMGMPSCHEME, FULL_KHAIN_LYNN, MORR_TM_AERO, & - FAST_KHAIN_LYNN_SHPUND !,MILBRANDT3MOM, NSSL_3MOM + NSSL_2MOM, FAST_KHAIN_LYNN_SHPUND !,MILBRANDT3MOM USE MODULE_MP_THOMPSON, ONLY: idx_bg1 + IMPLICIT NONE !====================================================================== ! Definitions @@ -106,6 +109,10 @@ SUBROUTINE diagnostic_output_nwp( & ! !====================================================================== + ! We are not changing any of the namelist settings. + + TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags + INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -378,7 +385,7 @@ SUBROUTINE diagnostic_output_nwp( & !.. graupel category mixing ratio and number concentration (or hail, if !.. available). This diagnostic uses the actual spectral distribution !.. assumptions, calculated by breaking the distribution into 50 bins -!.. from 0.5mm to 7.5cm. Once a minimum number concentration of 0.01 +!.. from 0.5mm to 7.5cm. Once a minimum number concentration of thresh_conc (5e-4) !.. particle per cubic meter of air is reached, from the upper size !.. limit, then this bin is considered the max size. !+---+-----------------------------------------------------------------+ @@ -714,19 +721,26 @@ SUBROUTINE diagnostic_output_nwp( & ! CASE (MILBRANDT3MOM) ! coming in future? - CASE (NSSL_1MOMLFO, NSSL_1MOM, NSSL_2MOM, NSSL_2MOMG, NSSL_2MOMCCN) + CASE (NSSL_2MOM) +! Only treat 1-moment option here. 2- and 3-moment are now done in the microphysics +! + if ( config_flags%nssl_2moment_on == 0 ) then ! single-moment scheme_has_graupel = .true. xrho_g = nssl_rho_qh N0exp = nssl_cnoh - if (PRESENT(qh_curr)) then + if (config_flags%nssl_hail_on==1) then xrho_g = nssl_rho_qhl N0exp = nssl_cnohl endif xam_g = 3.1415926536/6.0*xrho_g - if (PRESENT(ng_curr)) xmu_g = nssl_alphah - if (PRESENT(nh_curr)) xmu_g = nssl_alphahl + + IF (config_flags%nssl_hail_on==1) THEN + xmu_g = nssl_alphahl + ELSE + xmu_g = nssl_alphah + ENDIF if (xmu_g .NE. 0.) then cge(1) = xbm_g + 1. @@ -736,11 +750,14 @@ SUBROUTINE diagnostic_output_nwp( & cgg(n) = WGAMMA(cge(n)) enddo endif + + ENDIF ! NSSL scheme has many options, but, if single-moment, just fill ! in the number array for graupel from built-in assumptions. - if (.NOT.(PRESENT(nh_curr).OR.PRESENT(ng_curr)) ) then +! if (.NOT.(PRESENT(nh_curr).OR.PRESENT(ng_curr)) ) then + if ( config_flags%nssl_2moment_on == 0 ) then ! single-moment ! !$OMP PARALLEL DO & ! !$OMP PRIVATE ( ij ) DO ij = 1 , num_tiles diff --git a/phys/module_diagnostics_driver.F b/phys/module_diagnostics_driver.F index 78921d5f1a..6fa5708f74 100644 --- a/phys/module_diagnostics_driver.F +++ b/phys/module_diagnostics_driver.F @@ -39,9 +39,8 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, THOMPSONGH, & MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & - NSSL_2MOM, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & MILBRANDT2MOM , CAMMGMPSCHEME, FAST_KHAIN_LYNN_SHPUND, FULL_KHAIN_LYNN, & - MORR_TM_AERO !TWG add !,MILBRANDT3MOM, NSSL_3MOM, MORR_MILB_P3 + NSSL_2MOM, MORR_TM_AERO !TWG add !,MILBRANDT3MOM, MORR_MILB_P3 USE module_driver_constants, ONLY: max_plevs, max_zlevs @@ -419,9 +418,10 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & mp_select: SELECT CASE(config_flags%mp_physics) - CASE (LINSCHEME, WSM6SCHEME, WDM6SCHEME, GSFCGCESCHEME, NSSL_1MOMLFO) + CASE (LINSCHEME, WSM6SCHEME, WDM6SCHEME, GSFCGCESCHEME) - CALL diagnostic_output_nwp( & + CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -469,6 +469,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE (THOMPSON, THOMPSONAERO) CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -518,6 +519,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE (THOMPSONGH) CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -569,6 +571,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE (MORR_TWO_MOMENT, MORR_TM_AERO) ! TWG add CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -614,57 +617,11 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,ADAPTIVE_TS=config_flags%use_adaptive_time_step & ) - CASE (NSSL_1MOM) - CALL diagnostic_output_nwp( & - U=grid%u_2 ,V=grid%v_2 & - ,TEMP=grid%t_phy ,P8W=p8w & - ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & - ,XTIME=grid%xtime & - ! Selection flag - ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn - ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn - ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn - ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn - ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn - ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn - ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn - ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn - ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn - ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn - ,CURR_SECS2=curr_secs2 & - ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & - ,DIAGFLAG=diag_flag & - ,HISTORY_INTERVAL=grid%history_interval & - ,ITIMESTEP=grid%itimestep & - ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & - ,WSPD10MAX=grid%wspd10max & - ,UP_HELI_MAX=grid%up_heli_max & - ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & - ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & - ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & - ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & - ,REFD_MAX=grid%refd_max & - ,refl_10cm=grid%refl_10cm & - ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn - ,QG_CURR=moist(ims,kms,jms,P_QG) & - ,QH_CURR=moist(ims,kms,jms,P_QH) & ! gthompsn - ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & - ! Dimension arguments - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & - ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & - ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & - ,KTS=k_start, KTE=min(k_end,kde-1) & - ,NUM_TILES=grid%num_tiles & - ,MAX_TIME_STEP=grid%max_time_step & - ,ADAPTIVE_TS=config_flags%use_adaptive_time_step & - ) - - CASE (MILBRANDT2MOM, NSSL_2MOM, NSSL_2MOMCCN) + CASE (MILBRANDT2MOM, NSSL_2MOM) CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & @@ -724,8 +681,6 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ! CASE (ETAMPNEW) -! CASE (NSSL_3MOM) - ! CASE (MILBRANDT3MOM) ! CASE (MORR_MILB_P3) @@ -743,6 +698,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CASE DEFAULT CALL diagnostic_output_nwp( & + config_flags=config_flags, & U=grid%u_2 ,V=grid%v_2 & ,TEMP=grid%t_phy ,P8W=p8w & ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & diff --git a/phys/module_fr_fire_atm.F b/phys/module_fr_fire_atm.F index 0cb3bfcf23..ac7acf5cae 100644 --- a/phys/module_fr_fire_atm.F +++ b/phys/module_fr_fire_atm.F @@ -21,7 +21,8 @@ subroutine add_fire_tracer_emissions( & its,ite,kts,kte,jts,jte, & rho,dz8w, & burnt_area_dt,fgip, & - tracer,fire_tracer_smoke & + tracer,fire_tracer_smoke, & + fire_smk_scheme,fire_smk_peak,fire_smk_ext,fire_tg_ub,zs,z_at_w & !for Truncated Gaussian dist. ) implicit none @@ -33,10 +34,23 @@ subroutine add_fire_tracer_emissions( & real,intent(in)::rho(ims:ime,kms:kme,jms:jme),dz8w(ims:ime,kms:kme,jms:jme) real,intent(in),dimension(ifms:ifme,jfms:jfme)::burnt_area_dt,fgip real,intent(inout)::tracer(ims:ime,kms:kme,jms:jme,num_tracer) + +integer, intent(in) :: fire_smk_scheme !switch for smoke release +real, intent(in) :: fire_smk_peak !peak smoke release height for TG +real, intent(in) :: fire_smk_ext !smoke extinction depth for TG +real, intent(in) :: fire_tg_ub !upper bound of TG +real, intent(in), dimension( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl +real, intent(in), dimension( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl) + ! local integer::isz1,jsz1,isz2,jsz2,ir,jr integer::i,j,ibase,jbase,i_f,ioff,j_f,joff real::avgw,emis,conv +integer :: i_st,i_en,j_st,j_en + +!local for TG +integer :: k,k_st,k_en +real, dimension(its:ite,kts:kte,jts:jte) :: prop_smk isz1 = ite-its+1 jsz1 = jte-jts+1 @@ -46,18 +60,44 @@ subroutine add_fire_tracer_emissions( & jr=jsz2/jsz1 avgw = 1.0/(ir*jr) -do j=max(jds+1,jts),min(jte,jde-2) +! --- set loop indicies +i_st = MAX(its,ids+1) +i_en = MIN(ite,ide-2) +j_st = MAX(jts,jds+1) +j_en = MIN(jte,jde-2) + +! --- check if TG used: init prop_smk +if (fire_smk_scheme .eq. 1) then + k_st = kts + k_en = MIN(kte,kde-1) + call tg_dist(ims,ime, kms,kme, jms,jme, & + i_st,i_en, j_st,j_en, k_st,k_en, dz8w, & + fire_smk_peak,fire_tg_ub,fire_smk_ext,z_at_w,zs, & + prop_smk) +end if + +do j=j_st,j_en jbase=jtfs+jr*(j-jts) - do i=max(ids+1,its),min(ite,ide-2) + do i=i_st,i_st ibase=ifts+ir*(i-its) do joff=0,jr-1 j_f=joff+jbase do ioff=0,ir-1 i_f=ioff+ibase - if (num_tracer >0)then + if (num_tracer > 0)then + if (fire_smk_scheme .eq. 0)then emis=avgw*fire_tracer_smoke*burnt_area_dt(i_f,j_f)*fgip(i_f,j_f)*1000/(rho(i,kts,j)*dz8w(i,kts,j)) ! g_smoke/kg_air tracer(i,kts,j,p_fire_smoke)=tracer(i,kts,j,p_fire_smoke)+emis - endif + + else if (fire_smk_scheme .eq. 1)then + do k = k_st,k_en + emis=prop_smk(i,k,j)*avgw*fire_tracer_smoke*burnt_area_dt(i_f,j_f)*fgip(i_f,j_f)*1000/(rho(i,k,j)*dz8w(i,k,j)) ! g_smoke/kg_air + tracer(i,k,j,p_fire_smoke)=tracer(i,k,j,p_fire_smoke)+emis + end do + else + call wrf_error_fatal('Invalid fire smoke release option: check fire_smk_scheme namelist option') + end if + end if enddo enddo enddo @@ -75,6 +115,7 @@ SUBROUTINE fire_tendency( & its,ite, kts,kte, jts,jte, & grnhfx,grnqfx,canhfx,canqfx, & ! heat fluxes summed up to atm grid alfg,alfc,z1can, & ! coeffients, properties, geometry + fire_sfc_flx,fire_heat_peak,fire_tg_ub, & !options for heat release zs,z_at_w,dz8w,mu,c1h,c2h,rho, & rthfrten,rqvfrten) ! theta and Qv tendencies @@ -106,6 +147,9 @@ SUBROUTINE fire_tendency( & REAL, INTENT(in) :: alfg ! extinction depth surface fire heat (m) REAL, INTENT(in) :: alfc ! extinction depth crown fire heat (m) REAL, INTENT(in) :: z1can ! height of crown fire heat release (m) + INTEGER, INTENT(in) :: fire_sfc_flx !switch for the heat release scheme + REAL, INTENT(in) :: fire_heat_peak !peak heat release height for TG + REAL, INTENT(in) :: fire_tg_ub !upper bound for TG ! --- outgoing variables @@ -124,6 +168,8 @@ SUBROUTINE fire_tendency( & REAL :: fact_g, fact_c REAL :: alfg_i, alfc_i + REAL, DIMENSION( its:ite,kts:kte,jts:jte ) :: prop_heat !proportion of heat to be released fro TG dist. + REAL, DIMENSION( its:ite,kts:kte,jts:jte ) :: hfx,qfx !! character(len=128)::msg @@ -161,45 +207,72 @@ SUBROUTINE fire_tendency( & j_st = MAX(jts,jds+1) j_en = MIN(jte,jde-1) -! --- distribute fluxes +! --- check if TG is used, and create proportion + if (fire_sfc_flx .eq. 1) then !Truncated Gaussian scheme + call tg_dist(ims,ime, kms,kme, jms,jme, & + i_st,i_en, j_st,j_en, k_st,k_en, dz8w, & + fire_heat_peak,fire_tg_ub,alfg,z_at_w,zs, & + prop_heat) + end if +! --- distribute fluxes DO j = j_st,j_en DO k = k_st,k_en DO i = i_st,i_en - - ! --- set z (in meters above ground) - - z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st - - ! --- heat flux - - fact_g = cp_i * EXP( - alfg_i * z_w ) - IF ( z_w < z1can ) THEN - fact_c = cp_i - ELSE - fact_c = cp_i * EXP( - alfc_i * (z_w - z1can) ) - END IF - hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) - -!! write(msg,2)i,k,j,z_w,grnhfx(i,j),hfx(i,k,j) -!!2 format('hfx:',3i4,6e11.3) -!! call message(msg) - - ! --- vapor flux - - fact_g = xlv_i * EXP( - alfg_i * z_w ) - IF (z_w < z1can) THEN - fact_c = xlv_i - ELSE - fact_c = xlv_i * EXP( - alfc_i * (z_w - z1can) ) - END IF - qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) + if (fire_sfc_flx .eq. 0) then + ! --- set z (in meters above ground) + z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st + + ! --- heat flux + fact_g = cp_i * EXP( - alfg_i * z_w ) + IF ( z_w < z1can ) THEN + fact_c = cp_i + ELSE + fact_c = cp_i * EXP( - alfc_i * (z_w - z1can) ) + END IF + hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) + +!! write(msg,2)i,k,j,z_w,grnhfx(i,j),hfx(i,k,j) +!!2 format('hfx:',3i4,6e11.3) +!! call message(msg) + + ! --- vapor flux + + fact_g = xlv_i * EXP( - alfg_i * z_w ) + IF (z_w < z1can) THEN + fact_c = xlv_i + ELSE + fact_c = xlv_i * EXP( - alfc_i * (z_w - z1can) ) + END IF + qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) -!! if(hfx(i,k,j).ne.0. .or. qfx(i,k,j) .ne. 0.)then -!! write(msg,1)i,k,j,hfx(i,k,j),qfx(i,k,j) -!!1 format('tend:',3i6,2e11.3) -!! call message(msg) -! endif +!! if(hfx(i,k,j).ne.0. .or. qfx(i,k,j) .ne. 0.)then +!! write(msg,1)i,k,j,hfx(i,k,j),qfx(i,k,j) +!!1 format('tend:',3i6,2e11.3) +!! call message(msg) +! endif + else if (fire_sfc_flx .eq. 1) then !Truncated Gaussian scheme + ! heat flux + fact_g = prop_heat(i,k,j) * cp_i + IF ( z_w < z1can ) THEN + fact_c = cp_i + ELSE + fact_c = cp_i * prop_heat(i,k,j) + END IF + hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canqfx(i,j) + + ! vapor flux + fact_g = prop_heat(i,k,j) * xlv_i + IF (z_w < z1can) THEN + fact_c = xlv_i + ELSE + fact_c = xlv_i * prop_heat(i,k,j) + END IF + qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) + + else + call wrf_error_fatal('Invalid fire heat release option: check fire_sfc_flx namelist option') + end if END DO END DO @@ -230,6 +303,69 @@ SUBROUTINE fire_tendency( & END SUBROUTINE fire_tendency +SUBROUTINE tg_dist(ims,ime, kms,kme, jms,jme, & + i_st,i_en, j_st,j_en, k_st,k_en, dz8w, & + fire_peak_hgt,fire_tg_ub,fire_ext_depth,z_at_w,zs, & + prop) + !!!! Truncated Gaussian Distribution Subroutine for Heat and Smoke Release + !!!! Developed by: Kasra Shamsaei (Univ. of Nevada, Reno) and Tim Juliano (NCAR/RAL) + !!!! Supervised by: Branko Kosovic (NCAR/RAL) + + IMPLICIT NONE + + INTEGER, INTENT(in) :: ims,ime, kms,kme, jms,jme + INTEGER, INTENT(in) :: i_st,i_en, j_st,j_en, k_st,k_en !loop indices + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w ! dz across w-lvl + REAL, INTENT(in) :: fire_peak_hgt !peak heat release height for Truncated Gaussian scheme + REAL, INTENT(in) :: fire_tg_ub !upper bound for the Truncated Gaussian scheme + REAL, INTENT(in) :: fire_ext_depth !extinction depth surface fire heat (m) + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl) + REAL, INTENT(out), DIMENSION( i_st:i_en,k_st:k_en,j_st:j_en ) :: prop !proportion of heat or smoke to be released + + ! --- local for Truncated Gaussian + INTEGER :: i,j,k + + REAL, PARAMETER :: acoef = 167./148., bcoef = 11./109., fire_tg_lb = 0. + REAL :: xia, xib + REAL :: phi_a, phi_b + REAL :: xi + REAL :: dz + REAL :: z_w + REAL :: prop_temp + + xia = (fire_tg_lb-fire_peak_hgt)/(0.5*fire_ext_depth) + xib = (fire_tg_ub-fire_peak_hgt)/(0.5*fire_ext_depth) + + phi_a = 0.5*(1.+tanh(acoef*xia+bcoef*(xia**3))) + phi_b = 0.5*(1.+tanh(acoef*xib+bcoef*(xib**3))) + + DO j = j_st,j_en + DO k = k_st,k_en + DO i = i_st,i_en + + xi=(z_w-fire_peak_hgt)/(0.5*fire_ext_depth) + + prop_temp = 0.5*(acoef+3.*bcoef*(xi**2))/(0.5*fire_ext_depth)*(1.-(tanh(acoef*xi+bcoef*(xi**3)))**2) + prop_temp = prop_temp / (phi_b-phi_a) + + !discretize the continuous function + if (k .eq. k_st) then + dz = 0.5 * dz8w(i,k,j) + else if (k .eq. k_en) then + dz = 0.5 * dz8w(i,k-1,j) + else + dz = 0.5 * (dz8w(i,k,j) + dz8w(i,k-1,j)) + end if + + prop(i,k,j) = prop_temp * dz + + END DO + END DO + END DO + +END SUBROUTINE tg_dist + ! !*** ! diff --git a/phys/module_fr_fire_driver.F b/phys/module_fr_fire_driver.F index 1e1898901f..acd6b35933 100644 --- a/phys/module_fr_fire_driver.F +++ b/phys/module_fr_fire_driver.F @@ -352,7 +352,8 @@ subroutine fire_driver_em ( grid , config_flags & ips,ipe,kps,kpe,jps,jpe, & rho,dz8w, & grid%burnt_area_dt,grid%fgip, & - grid%tracer,config_flags%fire_tracer_smoke) + grid%tracer,config_flags%fire_tracer_smoke, & + config_flags%fire_smk_scheme,config_flags%fire_smk_peak,config_flags%fire_smk_ext,config_flags%fire_tg_ub,grid%ht,z_at_w) endif ! DME enddo diff --git a/phys/module_fr_fire_driver_wrf.F b/phys/module_fr_fire_driver_wrf.F index e77b96f819..c12019d7b0 100644 --- a/phys/module_fr_fire_driver_wrf.F +++ b/phys/module_fr_fire_driver_wrf.F @@ -130,6 +130,7 @@ subroutine fire_driver_em_step (grid , config_flags & its,ite, kts,kte, jts,jte, & ! grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx, & ! fluxes on atm grid config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt, & + config_flags%fire_sfc_flx,config_flags%fire_heat_peak,config_flags%fire_tg_ub, & grid%ht,z_at_w,dz8w,grid%mut,grid%c1h,grid%c2h,rho, & grid%rthfrten,grid%rqvfrten) ! out diff --git a/phys/module_fr_fire_phys.F b/phys/module_fr_fire_phys.F index 3f8708031e..7e9c4a49c8 100644 --- a/phys/module_fr_fire_phys.F +++ b/phys/module_fr_fire_phys.F @@ -58,7 +58,7 @@ module module_fr_fire_phys ! 4. add default !*** dimensions - INTEGER, PARAMETER :: mfuelcats = 30 ! allowable number of fuel categories + INTEGER, PARAMETER :: mfuelcats = 60 ! allowable number of fuel categories INTEGER, PARAMETER ::max_moisture_classes=5 !*** @@ -148,7 +148,7 @@ module module_fr_fire_phys ! FUEL MODEL 14: no fuel ! scalar fuel coefficients - REAL, SAVE:: cmbcnst,hfgl,fuelmc_g,fuelmc_c + REAL, SAVE:: cmbcnst,hfgl,fuelmc_g,fuelmc_g_lh,fuelmc_c ! computed values REAL, SAVE:: fuelheat @@ -156,6 +156,7 @@ module module_fr_fire_phys DATA cmbcnst / 17.433e+06/ ! J/kg dry fuel DATA hfgl / 17.e4 / ! W/m^2 DATA fuelmc_g / 0.08 / ! set = 0 for dry surface fuel + DATA fuelmc_g_lh / 1.20 / ! set >= 1.20 for uncured live herb fuels; <=0.30 for fully cured live herb fuels DATA fuelmc_c / 1.00 / ! set = 0 for dry canopy ! REAL, PARAMETER :: bmst = fuelmc_g/(1+fuelmc_g) ! REAL, PARAMETER :: fuelheat = cmbcnst * 4.30e-04 ! convert J/kg to BTU/lb @@ -164,9 +165,11 @@ module module_fr_fire_phys ! fuel categorytables - INTEGER, PARAMETER :: nf=14 ! number of fuel categories in data stmts - INTEGER, SAVE :: nfuelcats = 13 ! number of fuel categories that are specified - INTEGER, PARAMETER :: zf = mfuelcats-nf ! number of zero fillers in data stmt + INTEGER, PARAMETER :: nf0=14 ! number of fuel categories in old Anderson fuel model + INTEGER, PARAMETER :: nf=54 ! number of fuel categories in data stmts + INTEGER, SAVE :: nfuelcats = 53 ! number of fuel categories that are specified + INTEGER, PARAMETER :: zf = mfuelcats-nf ! number of zero fillers in data stmt + INTEGER, PARAMETER :: zf0 = mfuelcats-nf0 ! number of zero fillers in old parameters originally defined for Anderson fuel model INTEGER, SAVE :: no_fuel_cat = 14 ! special category outside of 1:nfuelcats CHARACTER (len=80), DIMENSION(mfuelcats ), save :: fuel_name INTEGER, DIMENSION( mfuelcats ), save :: ichap @@ -174,7 +177,8 @@ module module_fr_fire_phys fueldepthm,fueldens,fuelmce, & savr,st,se, & fgi_1h,fgi_10h,fgi_100h,fgi_1000h,fgi_live, & - fgi_t,fmc_gwt + fgi_t,fmc_gwt, & + fgi_lh REAL, DIMENSION(mfuelcats,max_moisture_classes), save :: fgi_c, fmc_gw ! fuel moisture class weights DATA fuel_name /'1: Short grass (1 ft)', & '2: Timber (grass and understory)', & @@ -189,42 +193,158 @@ module module_fr_fire_phys '11: Light logging slash', & '12: Medium logging slash', & '13: Heavy logging slash', & - '14: no fuel', zf* ' '/ + '14: no fuel', & + '15: Short, Sparse Dry Climate Grass (Dynamic) [GR1 (101)]', & + '16: Low Load, Dry Climate Grass (Dynamic) GR2 (102)', & + '17: Low Load, Very Coarse, Humid Climate Grass (Dynamic) [GR3 (103)]', & + '18: Moderate Load, Dry Climate Grass (Dynamic) [GR4 (104)]', & + '19: Low Load, Humid Climate Grass (Dynamic) [GR5 (105)]', & + '20: Moderate Load, Humid Climate Grass (Dynamic) [GR6 (106)]', & + '21: High Load, Dry Climate Grass (Dynamic) [GR7 (107)]', & + '22: High Load, Very Coarse, Humid Climate Grass (Dynamic) [GR8 (108)]', & + '23: Very High Load, Humid Climate Grass (Dynamic) [GR9 (109)]', & + '24: Low Load, Dry Climate Grass-Shrub (Dynamic) [GS1 (121)]', & + '25: Moderate Load, Dry Climate Grass-Shrub (Dynamic) [GS2 (122)]', & + '26: Moderate Load, Humid Climate Grass-Shrub (Dynamic) [GS3 (123)]', & + '27: High Load, Humid Climate Grass-Shrub (Dynamic) [GS4 (124)]', & + '28: Low Load Dry Climate Shrub (Dynamic) [SH1 (141)]', & + '29: Moderate Load Dry Climate Shrub [SH2 (142)]', & + '30: Moderate Load, Humid Climate Shrub [SH3 (143)]', & + '31: Low Load, Humid Climate Timber-Shrub [SH4 (144)]', & + '32: High Load, Dry Climate Shrub [SH5 (145)]', & + '33: Low Load, Humid Climate Shrub [SH6 (146)]', & + '34: Very High Load, Dry Climate Shrub [SH7 (147)]', & + '35: High Load, Humid Climate Shrub [SH8 (148)]', & + '36: Very High Load, Humid Climate Shrub (Dynamic) [SH9 (149)]', & + '37: Low Load Dry Climate Timber-Grass-Shrub (Dynamic) [TU1 (161)]', & + '38: Moderate Load, Humid Climate Timber-Shrub [TU2 (162)]', & + '39: Moderate Load, Humid Climate Timber-Grass-Shrub (Dynamic) [TU3 (163)]', & + '40: Dwarf Conifer With Understory [TU4 (164)]', & + '41: Very High Load, Dry Climate Timber-Shrub [TU5 (165)]', & + '42: Low Load Compact Conifer Litter [TL1 (181)]', & + '43: Low Load Broadleaf Litter [TL2 (182)]', & + '44: Moderate Load Conifer Litter [TL3 (183)]', & + '45: Small downed logs [TL4 (184)]', & + '46: High Load Conifer Litter [TL5 (185)]', & + '47: Moderate Load Broadleaf Litter [TL6 (186)]', & + '48: Large Downed Logs [TL7 (187)]', & + '49: Long-Needle Litter [TL8 (188)]', & + '50: Very High Load Broadleaf Litter [TL9 (189)]', & + '51: Low Load Activity Fuel [SB1 (201)]', & + '52: Moderate Load Activity Fuel or Low Load Blowdown [SB2 (202)]', & + '53: High Load Activity Fuel or Moderate Load Blowdown [SB3 (203)]', & + '54: High Load Blowdown [SB4 (204)]', zf* ' '/ DATA windrf /0.36, 0.36, 0.44, 0.55, 0.42, 0.44, 0.44, & - 0.36, 0.36, 0.36, 0.36, 0.43, 0.46, 1e-7, zf*0 / - DATA fueldepthm /0.305, 0.305, 0.762, 1.829, 0.61, 0.762,0.762, & - 0.0610, 0.0610, 0.305, 0.305, 0.701, 0.914, 0.305,zf*0. / - DATA savr / 3500., 2784., 1500., 1739., 1683., 1564., 1562., & - 1889., 2484., 1764., 1182., 1145., 1159., 3500., zf*0. / - DATA fuelmce / 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, & - 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12 , zf*0. / + 0.36, 0.36, 0.36, 0.36, 0.43, 0.46, 1e-7, zf0*0 / + DATA fueldepthm /0.305, 0.305, 0.762, 1.829, 0.61, 0.762,0.762, 0.0610, 0.0610, 0.305, 0.305, 0.701, 0.914, 0.305, & ! Anderson 13 + no fuel + 0.1219, 0.3048, 0.6096, 0.6096, 0.4572, 0.4572, 0.9144, 1.2192, 1.5240, & ! Scott & Burgan: GR fuels (1-9) + 0.2743, 0.4572, 0.5486, 0.6401, & ! Scott & Burgan: GS fuels (1-4) + 0.3048, 0.3048, 0.7315, 0.9144, 1.8288, 0.6096, 1.8288, 0.9144, 1.3411, & ! Scott & Burgan: SH fuels (1-9) + 0.1829, 0.3048, 0.3962, 0.1524, 0.3048, & ! Scott & Burgan: TU fuels (1-5) + 0.0610, 0.0610, 0.0914, 0.1219, 0.1829, 0.0914, 0.1219, 0.0914, 0.1829, & ! Scott & Burgan: TL fuels (1-9) + 0.3048, 0.3048, 0.3658, 0.8230, & ! Scott & Burgan: SB fuels (1-4) + zf*0. / + DATA savr / 3500., 2784., 1500., 1739., 1683., 1564., 1562., 1889., 2484., 1764., 1182., 1145., 1159., 3500., & ! Anderson 13 + no fuel + 2200., 2000., 1500., 2000., 1800., 2200., 2000., 1500., 1800., & ! Scott & Burgan: GR fuels (1-9) + 2000., 2000., 1800., 1800., & ! Scott & Burgan: GS fuels (1-4) + 2000., 2000., 1600., 2000., 750., 750., 750., 750., 750., & ! Scott & Burgan: SH fuels (1-9) + 2000., 2000., 1800., 2300., 1500., & ! Scott & Burgan: TU fuels (1-5) + 2000., 2000., 2000., 2000., 2000., 2000., 2000., 1800., 1800., & ! Scott & Burgan: TL fuels (1-9) + 2000., 2000., 2000., 2000., & ! Scott & Burgan: SB fuels (1-4) + zf*0. / + DATA fuelmce / 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12, & ! Anderson 13 + no fuel + 0.15, 0.15, 0.30, 0.15, 0.40, 0.40, 0.15, 0.30, 0.40, & ! Scott & Burgan: GR fuels (1-9) + 0.15, 0.15, 0.40, 0.40, & ! Scott & Burgan: GS fuels (1-4) + 0.15, 0.15, 0.40, 0.30, 0.15, 0.30, 0.15, 0.40, 0.40, & ! Scott & Burgan: SH fuels (1-9) + 0.20, 0.30, 0.30, 0.12, 0.25, & ! Scott & Burgan: TU fuels (1-5) + 0.30, 0.25, 0.20, 0.25, 0.25, 0.25, 0.25, 0.35, 0.35, & ! Scott & Burgan: TL fuels (1-9) + 0.25, 0.25, 0.25, 0.25, & ! Scott & Burgan: SB fuels (1-4) + zf*0. / DATA fueldens / nf * 32., zf*0. / ! 32 if solid, 19 if rotten. DATA st / nf* 0.0555 , zf*0./ DATA se / nf* 0.010 , zf*0./ ! ----- Notes on weight: (4) - best fit of data from D. Latham (pers. comm.); ! (5)-(7) could be 60-120; (8)-(10) could be 300-1600; ! (11)-(13) could be 300-1600 - DATA weight / 7., 7., 7., 180., 100., 100., 100., & - 900., 900., 900., 900., 900., 900., 7. , zf*0./ + DATA weight / 7., 7., 7., 180., 100., 100., 100., 900., 900., 900., 900., 900., 900., 7., & ! Anderson 13 + no fuel + 7., 7., 7., 7., 7., 7., 7., 7., 7., & ! Scott & Burgan: GR fuels (1-9) + 7., 7., 7., 7., & ! Scott & Burgan: GS fuels (1-4) + 100., 100., 100., 100., 180., 100., 180., 100., 100., & ! Scott & Burgan: SH fuels (1-9) + 900., 900., 900., 900., 900., & ! Scott & Burgan: TU fuels (1-5) + 900., 900., 900., 900., 900., 900., 900., 900., 900., & ! Scott & Burgan: TL fuels (1-9) + 900., 900., 900., 900., & ! Scott & Burgan: SB fuels (1-4) + zf*0./ ! ----- 1.12083 is 5 tons/acre. 5-50 tons/acre orig., 100-300 after blowdown DATA fci_d / 0., 0., 0., 1.123, 0., 0., 0., & - 1.121, 1.121, 1.121, 1.121, 1.121, 1.121, 0., zf*0./ + 1.121, 1.121, 1.121, 1.121, 1.121, 1.121, 0., zf0*0./ DATA fct / 60., 60., 60., 60., 60., 60., 60., & - 60., 120., 180., 180., 180., 180. , 60. , zf*0. / - DATA ichap / 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 , zf*0/ + 60., 120., 180., 180., 180., 180. , 60. , zf0*0. / + DATA ichap / 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 , zf0*0/ ! DATA fmc_gw05 / 0.000, 0.023, 0.000, 0.230, 0.092, 0.000, 0.017, 0.000, 0.000, 0.092, 0.000, 0.000, 0.000, zf*0/ ! fuel loading 1-h, 10-h, 100-h, 1000-h, live following Albini 1976 as reprinted in Anderson 1982 Table 1 (for proportions only) ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 - DATA fgi_1h / 0.74, 2.00, 3.01, 5.01, 1.00, 1.50, 1.13, 1.50, 2.92, 3.01, 1.50, 4.01, 7.01, 0.0, zf*0./ - DATA fgi_10h / 0.00, 1.00, 0.00, 4.01, 0.50, 2.50, 1.87, 1.00, 0.41, 2.00, 4.51, 14.03, 23.04, 0.0, zf*0./ - DATA fgi_100h / 0.00, 0.50, 0.00, 2.00, 0.00, 2.00, 1.50, 2.50, 0.15, 5.01, 5.51, 16.53, 28.05, 0.0, zf*0./ - DATA fgi_1000h / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, zf*0./ - DATA fgi_live / 0.00, 0.50, 0.000, 5.01, 2.00, 0.00, 0.37, 0.00, 0.00, 2.00, 0.00, 2.3, 0.00, 0.0, zf*0./ - -! total fuel loading kg/m^2 - DATA fgi / 0.166, 0.896, 0.674, 3.591, 0.784, 1.344, 1.091, 1.120, 0.780, 2.692, 2.582, 7.749, 13.024, 1.e-7, zf*0. / + DATA fgi_1h / 0.74, 2.00, 3.01, 5.01, 1.00, 1.50, 1.13, 1.50, 2.92, 3.01, 1.50, 4.01, 7.01, 0.0, & ! Anderson 13 + no fuel + 0.10, 0.10, 0.10, 0.25, 0.40, 0.10, 1.00, 0.50, 1.00, & ! Scott & Burgan: GR fuels (1-9) + 0.20, 0.50, 0.30, 1.90, & ! Scott & Burgan: GS fuels (1-4) + 0.25, 1.35, 0.45, 0.85, 3.60, 2.90, 3.50, 2.05, 4.50, & ! Scott & Burgan: SH fuels (1-9) + 0.20, 0.95, 1.10, 4.50, 4.00, & ! Scott & Burgan: TU fuels (1-5) + 1.00, 1.40, 0.50, 0.50, 1.15, 2.40, 0.30, 5.80, 6.65, & ! Scott & Burgan: TL fuels (1-9) + 1.50, 4.50, 5.50, 5.25, & ! Scott & Burgan: SB fuels (1-4) + zf*0. / + DATA fgi_10h / 0.00, 1.00, 0.00, 4.01, 0.50, 2.50, 1.87, 1.00, 0.41, 2.00, 4.51, 14.03, 23.04, 0.0, & ! Anderson 13 + no fuel + 0.00, 0.00, 0.40, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, & ! Scott & Burgan: GR fuels (1-9) + 0.00, 0.50, 0.25, 0.30, & ! Scott & Burgan: GS fuels (1-4) + 0.25, 2.40, 3.00, 1.15, 2.10, 1.45, 5.30, 3.40, 2.45, & ! Scott & Burgan: SH fuels (1-9) + 0.90, 1.80, 0.15, 0.00, 4.00, & ! Scott & Burgan: TU fuels (1-5) + 2.20, 2.30, 2.20, 1.50, 2.50, 1.20, 1.40, 1.40, 3.30, & ! Scott & Burgan: TL fuels (1-9) + 3.00, 4.25, 2.75, 3.50, & ! Scott & Burgan: SB fuels (1-4) + zf*0./ + DATA fgi_100h / 0.00, 0.50, 0.00, 2.00, 0.00, 2.00, 1.50, 2.50, 0.15, 5.01, 5.51, 16.53, 28.05, 0.0, & ! Anderson 13 + no fuel + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: GR fuels (1-9) + 0.00, 0.00, 0.00, 0.10, & ! Scott & Burgan: GS fuels (1-4) + 0.00, 0.75, 0.00, 0.20, 0.00, 0.00, 2.20, 0.85, 0.00, & ! Scott & Burgan: SH fuels (1-9) + 1.50, 1.25, 0.25, 0.00, 3.00, & ! Scott & Burgan: TU fuels (1-5) + 3.60, 2.20, 2.80, 4.20, 4.40, 1.20, 8.10, 1.10, 4.15, & ! Scott & Burgan: TL fuels (1-9) + 11.00, 4.00, 3.00, 5.25, & ! Scott & Burgan: SB fuels (1-4) + zf*0./ + DATA fgi_1000h / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & ! Anderson 13 + no fuel + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: GR fuels (1-9) + 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: GS fuels (1-4) + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: SH fuels (1-9) + 0.00, 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: TU fuels (1-5) + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: TL fuels (1-9) + 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: SB fuels (1-4) + zf*0./ + DATA fgi_live / 0.00, 0.50, 0.00, 5.01, 2.00, 0.00, 0.37, 0.00, 0.00, 2.00, 0.0, 0.0, 0.0, 0.0, & ! Anderson 13 + no fuel + 0.30, 1.00, 1.50, 1.90, 2.50, 3.40, 5.40, 7.30, 9.00, & ! Scott & Burgan: GR fuels (1-9) + 0.50, 0.60, 1.45, 3.40, & ! Scott & Burgan: GS fuels (1-4) + 0.15, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.55, & ! Scott & Burgan: SH fuels (1-9) + 0.20, 0.00, 0.65, 0.00, 0.00, & ! Scott & Burgan: TU fuels (1-5) + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: TL fuels (1-9) + 0.00, 0.00, 0.00, 0.00, & ! Scott & Burgan: SB fuels (1-4) + zf*0./ + +! fuel loading live herb fuels, kg/m^2 + DATA fgi_lh / 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & ! Anderson 13 + no fuel + 0.0673, 0.2242, 0.3363, 0.4259, 0.5604, 0.7622, 1.2105, 1.6364, 2.0175, & ! Scott & Burgan: GR fuels (1-9) + 0.1121, 0.1345, 0.3250, 0.7622, & ! Scott & Burgan: GS fuels (1-4) + 0.0336, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.3475, & ! Scott & Burgan: SH fuels (1-9) + 0.0448, 0.0000, 0.1457, 0.0000, 0.0000, & ! Scott & Burgan: TU fuels (1-5) + 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, & ! Scott & Burgan: TL fuels (1-9) + 0.0000, 0.0000, 0.0000, 0.0000, & ! Scott & Burgan: SB fuels (1-4) + zf*0. / + +! fuel loading 1-h, 10-h, and 100-h dead fuels combined, kg/m^2 + DATA fgi / 0.166, 0.896, 0.674, 3.591, 0.784, 1.344, 1.091, 1.120, 0.780, 2.692, 2.582, 7.749, 13.024, 1.e-7, & ! Anderson 13 + no fuel + 0.0224, 0.0224, 0.1121, 0.0560, 0.0897, 0.0224, 0.2242, 0.3363, 0.4483, & ! Scott & Burgan: GR fuels (1-9) + 0.0448, 0.2242, 0.1233, 0.5156, & ! Scott & Burgan: GS fuels (1-4) + 0.1121, 1.0088, 0.7734, 0.4932, 1.2778, 0.9751, 2.4659, 1.4123, 1.5580, & ! Scott & Burgan: SH fuels (1-9) + 0.5828, 0.8967, 0.3363, 1.0088, 2.4659, & ! Scott & Burgan: TU fuels (1-5) + 1.5244, 1.3226, 1.2329, 1.3899, 1.8046, 1.0760, 2.1969, 1.8606, 3.1608, & ! Scott & Burgan: TL fuels (1-9) + 3.4746, 2.8582, 2.5219, 3.1384, & ! Scott & Burgan: SB fuels (1-4) + zf*0. / ! ========================================================================= contains @@ -629,8 +749,8 @@ subroutine read_namelist_fire(init_fuel_moisture) !*** executable ! read -namelist /fuel_scalars/ cmbcnst,hfgl,fuelmc_g,fuelmc_c,nfuelcats,no_fuel_cat -namelist /fuel_categories/ fuel_name,windrf,fgi,fueldepthm,savr, & +namelist /fuel_scalars/ cmbcnst,hfgl,fuelmc_g,fuelmc_g_lh,fuelmc_c,nfuelcats,no_fuel_cat +namelist /fuel_categories/ fuel_name,windrf,fgi,fgi_lh,fueldepthm,savr, & fuelmce,fueldens,st,se,weight,fci_d,fct,ichap,fgi_1h,fgi_10h,fgi_100h,fgi_1000h,fgi_live namelist /fuel_moisture/ moisture_classes,drying_lag,wetting_lag,saturation_moisture,saturation_rain,rain_threshold, & drying_model,wetting_model, moisture_class_name,fmc_gc_initialization, fmc_1h,fmc_10h,fmc_100h,fmc_1000h,fmc_live @@ -684,7 +804,7 @@ subroutine read_namelist_fire(init_fuel_moisture) write(msg,*)'nfuelcats=',nfuelcats,' is too large, increase mfuelcats' call crash(msg) endif - if (no_fuel_cat >= 1 .and. no_fuel_cat <= nfuelcats)then + if (nfuelcats<14 .and. no_fuel_cat >= 1 .and. no_fuel_cat <= nfuelcats)then write(msg,*)'no_fuel_cat=',no_fuel_cat,' may not be between 1 and nfuelcats=',nfuelcats call crash(msg) endif @@ -782,6 +902,7 @@ subroutine init_fuel_cats(init_fuel_moisture) call wrf_dm_bcast_real(cmbcnst,1) call wrf_dm_bcast_real(hfgl,1) call wrf_dm_bcast_real(fuelmc_g,1) +call wrf_dm_bcast_real(fuelmc_g_lh,1) call wrf_dm_bcast_real(fuelmc_c,1) call wrf_dm_bcast_integer(nfuelcats,1) call wrf_dm_bcast_integer(no_fuel_cat,1) @@ -841,6 +962,8 @@ subroutine init_fuel_cats(init_fuel_moisture) call message(msg) write(msg,8)'fuelmc_g ',fuelmc_g call message(msg) +write(msg,8)'fuelmc_g_lh ',fuelmc_g_lh +call message(msg) write(msg,8)'fuelmc_c ',fuelmc_c call message(msg) write(msg,8)'fuelheat ',fuelheat @@ -940,7 +1063,7 @@ subroutine init_fuel_cats(init_fuel_moisture) ! and print to file IF ( wrf_dm_on_monitor() ) THEN -!jm call write_fuels_m(61,30.,1.) + call write_fuels_m(61,30.,1.) ENDIF end subroutine init_fuel_cats @@ -984,7 +1107,8 @@ subroutine write_fuels_m(nsteps,maxwind,maxslope) do k=1,nfuelcats write(iounit,10)k,'fuel_name',trim(fuel_name(k)),'FUEL MODEL NAME' call write_var(k,'windrf',windrf(k),'WIND REDUCTION FACTOR FROM 20ft TO MIDFLAME HEIGHT' ) - call write_var(k,'fgi',fgi(k),'INITIAL TOTAL MASS OF SURFACE FUEL (KG/M**2)' ) + call write_var(k,'fgi',fgi(k),'INITIAL TOTAL MASS OF SURFACE DEAD FUEL (KG/M**2)' ) + call write_var(k,'fgi_lh',fgi_lh(k),'INITIAL TOTAL MASS OF SURFACE LIVE HERB FUEL [SB: 1-h] (KG/M**2)' ) call write_var(k,'fueldepthm',fueldepthm(k),'FUEL DEPTH (M)') call write_var(k,'savr',savr(k),'FUEL PARTICLE SURFACE-AREA-TO-VOLUME RATIO, 1/FT') call write_var(k,'fuelmce',fuelmce(k),'MOISTURE CONTENT OF EXTINCTION') @@ -1128,60 +1252,53 @@ subroutine set_fire_params( & ksb(11)=11 ksb(12)=12 ksb(13)=13 -! Scott & Burgan crosswalks -! Short grass -- 1 -ksb(101)=1 -ksb(104)=1 -ksb(107)=1 -! Timber grass and understory -- 2 -ksb(102)=2 -ksb(121)=2 -ksb(122)=2 -ksb(123)=2 -ksb(124)=2 -! Tall grass -- 3 -ksb(103)=3 -ksb(105)=3 -ksb(106)=3 -ksb(108)=3 -ksb(109)=3 -! Chaparral -- 4 -ksb(145)=4 -ksb(147)=4 -! Brush -- 5 -ksb(142)=5 -! Dormant Brushi -- 6 -ksb(141)=6 -ksb(146)=6 -! Southern Rough -- 7 -ksb(143)=7 -ksb(144)=7 -ksb(148)=7 -ksb(149)=7 -! Compact Timber Litter -- 8 -ksb(181)=8 -ksb(183)=8 -ksb(184)=8 -ksb(187)=8 -! Hardwood Litter -- 9 -ksb(182)=9 -ksb(186)=9 -ksb(188)=9 -ksb(189)=9 -! Timber (understory) -- 10 -ksb(161)=10 -ksb(162)=10 -ksb(163)=10 -ksb(164)=10 -ksb(165)=10 -! Light Logging Slash -- 11 -ksb(185)=11 -ksb(201)=11 -! Medium Logging Slash -- 12 -ksb(202)=12 -! Heavy Logging Slash -- 13 -ksb(203)=13 -ksb(204)=13 +! full Scott and Burgan (2005) +! Grass (GR) +ksb(101)=15 +ksb(102)=16 +ksb(103)=17 +ksb(104)=18 +ksb(105)=19 +ksb(106)=20 +ksb(107)=21 +ksb(108)=22 +ksb(109)=23 +! Grass-Shrub (GS) +ksb(121)=24 +ksb(122)=25 +ksb(123)=26 +ksb(124)=27 +! Shrub (SH) +ksb(141)=28 +ksb(142)=29 +ksb(143)=30 +ksb(144)=31 +ksb(145)=32 +ksb(146)=33 +ksb(147)=34 +ksb(148)=35 +ksb(149)=36 +! Timber-Understory (TU) +ksb(161)=37 +ksb(162)=38 +ksb(163)=39 +ksb(164)=40 +ksb(165)=41 +! Timber litter (TL) +ksb(181)=42 +ksb(182)=43 +ksb(183)=44 +ksb(184)=45 +ksb(185)=46 +ksb(186)=47 +ksb(187)=48 +ksb(188)=49 +ksb(189)=50 +! Slash-Blowdown (SB) +ksb(201)=51 +ksb(202)=52 +ksb(203)=53 +ksb(204)=54 ! ****** ! @@ -1221,7 +1338,17 @@ subroutine set_fire_params( & ! exp(-600*0.85/1000) = approx 0.6 fp%ischap(i,j)=ichap(k) - fp%fgip(i,j)=fgi(k) + + ! DME dynamic live to dead fuel conversion and fuel load selection (start) + ! Use sum 1-h, 10-h, 100-h dead fuel loads for S&B classes + if ( fuelmc_g_lh .gt. 0.3 .AND. fuelmc_g_lh .lt. 1.2 ) then + fp%fgip(i,j)=fgi(k)+(1.0-(fuelmc_g_lh-0.3)/0.9)*fgi_lh(k) + elseif ( fuelmc_g_lh .le. 0.3 ) then + fp%fgip(i,j)=fgi(k)+fgi_lh(k) + else + fp%fgip(i,j)=fgi(k) + endif + if(fire_fmc_read.eq.1)then fp%fmc_g(i,j)=fuelmc_g endif @@ -1230,7 +1357,7 @@ subroutine set_fire_params( & ! don't need to be recalculated later. bmst = fp%fmc_g(i,j) / (1.+fp%fmc_g(i,j)) - fuelloadm= (1.-bmst) * fgi(k) ! fuelload without moisture + fuelloadm= (1.-bmst) * fp%fgip(i,j) ! fuelload without moisture fuelload = fuelloadm * (.3048)**2 * 2.205 ! to lb/ft^2 fueldepth = fueldepthm(k)/0.3048 ! to ft fp%betafl(i,j) = fuelload/(fueldepth * fueldens(k))! packing ratio diff --git a/phys/module_microphysics_driver.F b/phys/module_microphysics_driver.F index 7bfcaf901b..53514d346e 100644 --- a/phys/module_microphysics_driver.F +++ b/phys/module_microphysics_driver.F @@ -104,6 +104,7 @@ SUBROUTINE microphysics_driver( & ,snownc, snowncv & ,hailnc, hailncv & ,graupelnc, graupelncv & + ,hail_maxk1, hail_max2d & #if ( WRF_CHEM == 1 ) ,rainprod, evapprod & ,qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp & @@ -166,8 +167,8 @@ SUBROUTINE microphysics_driver( & USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, THOMPSON, THOMPSONAERO, THOMPSONGH, FAST_KHAIN_LYNN_SHPUND, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG, MADWRF_MP & - ,NSSL_1MOM,NSSL_1MOMLFO, FER_MP_HIRES_ADVECT & ! ,NSSL_3MOM & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, MADWRF_MP & + ,FER_MP_HIRES_ADVECT & ,WSM7SCHEME, WDM7SCHEME & ,NUWRF4ICESCHEME & ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN, P3_1CATEGORY, P3_1CATEGORY_NC, P3_2CATEGORY, P3_1CAT_3MOM & @@ -241,8 +242,9 @@ SUBROUTINE microphysics_driver( & USE module_mp_cammgmp_driver, ONLY: CAMMGMP ! CAM5's microphysics driver # endif ! USE module_mp_milbrandt3mom +#if (WRFPLUS != 1) & !defined( VAR4D ) USE module_mp_nssl_2mom - +#endif USE module_mixactivate, only: prescribe_aerosol_mixactivate ! For checking model timestep is history time (for radar reflectivity) @@ -681,7 +683,8 @@ SUBROUTINE microphysics_driver( & ,GRAUPELNC & ,GRAUPELNCV & ,HAILNC & - ,HAILNCV + ,HAILNCV & + ,hail_maxk1, hail_max2d #if ( WRF_CHEM == 1) ! NUWRF JJS 20110525 vvvvv @@ -783,6 +786,10 @@ SUBROUTINE microphysics_driver( & REAL :: constants_irrigation,tloc,irr_start,phase INTEGER, OPTIONAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: irr_rand_field +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + !--------------------------------------------------------------------- ! check for microphysics type. We need a clean way to ! specify these things! @@ -898,7 +905,7 @@ SUBROUTINE microphysics_driver( & IF( PRESENT(chem_opt) .AND. PRESENT(progn) ) THEN ! ERM: check whether to use built-in droplet nucleation or use qndrop from CHEM - IF ( mp_physics==NSSL_2MOMCCN .or. mp_physics==NSSL_2MOM .or. mp_physics==NSSL_2MOMG ) THEN + IF ( mp_physics==NSSL_2MOM .and. config_flags%nssl_2moment_on==1 ) THEN IF ( progn > 0 ) THEN IF ( .not. (chem_opt == 0 .or. chem_opt == 401) ) nssl_progn = .true. ELSE @@ -923,11 +930,11 @@ SUBROUTINE microphysics_driver( & its,ite, jts,jte, kts,kte, & F_QC=f_qc, F_QI=f_qi ) END IF - ELSEIF ( (chem_opt==0 .OR. chem_opt==401) .AND. progn==1 .AND. (mp_physics==NSSL_2MOMCCN .or. & - mp_physics==NSSL_2MOM .or. mp_physics==NSSL_2MOMG)) THEN + ELSEIF ( (chem_opt==0 .OR. chem_opt==401) .AND. progn==1 .AND. & + (mp_physics==NSSL_2MOM .and. config_flags%nssl_2moment_on==1)) THEN ! Do nothing here for the moment. Use activation of CCN within the NSSL_2MOM scheme instead, based on nssl_cccn namelist value. ELSEIF ( progn==1 .AND. mp_physics/=LINSCHEME .AND. mp_physics/=MORR_TWO_MOMENT & - .AND. mp_physics/=NSSL_2MOM .AND. mp_physics/=NSSL_2MOMCCN .AND. mp_physics/=NSSL_2MOMG ) THEN + .AND. .not. (mp_physics==NSSL_2MOM .and. config_flags%nssl_2moment_on==1) ) THEN call wrf_error_fatal( & "SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON or NSSL_2MOM.") END IF @@ -1926,136 +1933,20 @@ SUBROUTINE microphysics_driver( & ! Call wrf_error_fatal( 'arguments not present for calling milbrandt3mom') ! ENDIF - CASE (NSSL_1MOM) - CALL wrf_debug(100, 'microphysics_driver: calling nssl1mom') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. & - PRESENT (QR_CURR) .AND. & - PRESENT (QI_CURR) .AND. & - PRESENT (QS_CURR) .AND. & - PRESENT (QG_CURR) .AND. & - PRESENT (QH_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & -#endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - QHL=qh_curr, & -! CCW=qnc_curr, & -! CRW=qnr_curr, & -! CCI=qni_curr, & -! CSW=qns_curr, & -! CHW=qng_curr, & -! CHL=qnh_curr, & - VHW=qvolg_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - HAILNC = HAILNC, & - HAILNCV = HAILNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & - diagflag = diagflag, & - ke_diag = ke_diag, & - 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 & - ) - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_1mom') - ENDIF - - CASE (NSSL_1MOMLFO) - CALL wrf_debug(100, 'microphysics_driver: calling nssl1mom') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. & - PRESENT (QR_CURR) .AND. & - PRESENT (QI_CURR) .AND. & - PRESENT (QS_CURR) .AND. & - PRESENT (QG_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & -#endif - PRESENT ( W ) ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & - diagflag = diagflag, & - ke_diag = ke_diag, & - 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 & - ) - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_1momlfo') - ENDIF CASE (NSSL_2MOM) +#if (WRFPLUS != 1) & !defined( VAR4D ) + ! For all 1,2,3-moment options CALL wrf_debug(100, 'microphysics_driver: calling nssl2mom') IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNdrop_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & - PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & - PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & - PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & #if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & #endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & - PRESENT (QVOLH_CURR) .AND. F_QVOLH ) THEN + PRESENT ( W ) ) THEN CALL nssl_2mom_driver( & @@ -2075,8 +1966,12 @@ SUBROUTINE microphysics_driver( & CSW=qns_curr, & CHW=qng_curr, & CHL=qnh_curr, & - VHW=qvolg_curr, & - VHL=qvolh_curr, & + VHW=qvolg_curr, f_vhw=F_QVOLG, & + VHL=qvolh_curr, f_vhl=F_QVOLH, & + ZRW=qzr_curr, f_zrw = f_qzr, & + ZHW=qzg_curr, f_zhw = f_qzg, & + ZHL=qzh_curr, f_zhl = f_qzh, & + cn=qnn_curr, f_cn=f_qnn, & PII=pi_phy, & P=p, & W=w, & @@ -2111,6 +2006,9 @@ SUBROUTINE microphysics_driver( & has_reqc=has_reqc, & ! ala G. Thompson has_reqi=has_reqi, & ! ala G. Thompson has_reqs=has_reqs, & ! ala G. Thompson + hail_maxk1=hail_maxk1, & + hail_max2d=hail_max2d, & + nwp_diagnostics=config_flags%nwp_diagnostics, & 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 & @@ -2119,165 +2017,7 @@ SUBROUTINE microphysics_driver( & ELSE Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') ENDIF - - CASE (NSSL_2MOMG) - CALL wrf_debug(100, 'microphysics_driver: calling nssl2mom') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNdrop_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & - PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & - PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & #endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. F_QVOLG ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - ! CCW=qnc_curr, & - CCW=qndrop_curr, & - CRW=qnr_curr, & - CCI=qni_curr, & - CSW=qns_curr, & - CHW=qng_curr, & - VHW=qvolg_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - HAILNC = HAILNC, & - HAILNCV = HAILNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & -#if ( WRF_CHEM == 1 ) - WETSCAV_ON = config_flags%wetscav_onoff == 1, & - EVAPPROD=evapprod,RAINPROD=rainprod, & -#endif - nssl_progn=nssl_progn, & - diagflag = diagflag, & - cu_used=cu_used, & - qrcuten=qrcuten, & ! hm - qscuten=qscuten, & ! hm - qicuten=qicuten, & ! hm - qccuten=qccuten, & ! hm - re_cloud=re_cloud, & - re_ice=re_ice, & - re_snow=re_snow, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - 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 & - ) - - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2momg') - ENDIF - - CASE (NSSL_2MOMCCN) - CALL wrf_debug(100, 'microphysics_driver: calling nssl_2momccn') - IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNDROP_CURR) .AND. & - PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & - PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & - PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & - PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & - PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -#if (EM_CORE==1) - PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & - PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & - PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & -#endif - PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & - PRESENT (QVOLH_CURR) .AND. F_QVOLH .AND. & - PRESENT( QNN_CURR ) ) THEN - - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - TH=th, & - QV=qv_curr, & - QC=qc_curr, & - QR=qr_curr, & - QI=qi_curr, & - QS=qs_curr, & - QH=qg_curr, & - QHL=qh_curr, & -! CCW=qnc_curr, & - CCW=qndrop_curr, & - CRW=qnr_curr, & - CCI=qni_curr, & - CSW=qns_curr, & - CHW=qng_curr, & - CHL=qnh_curr, & - VHW=qvolg_curr, & - VHL=qvolh_curr, & - cn=qnn_curr, & - PII=pi_phy, & - P=p, & - W=w, & - DZ=dz8w, & - DTP=dt, & - DN=rho, & - RAINNC = RAINNC, & - RAINNCV = RAINNCV, & - SNOWNC = SNOWNC, & - SNOWNCV = SNOWNCV, & - HAILNC = HAILNC, & - HAILNCV = HAILNCV, & - GRPLNC = GRAUPELNC, & - GRPLNCV = GRAUPELNCV, & - SR=SR, & - dbz = refl_10cm, & -#if ( WRF_CHEM == 1 ) - WETSCAV_ON = config_flags%wetscav_onoff == 1, & - EVAPPROD=evapprod,RAINPROD=rainprod,& -#endif - nssl_progn=nssl_progn, & - diagflag = diagflag, & - ke_diag = ke_diag, & - cu_used=cu_used, & - qrcuten=qrcuten, & ! hm - qscuten=qscuten, & ! hm - qicuten=qicuten, & ! hm - qccuten=qccuten, & ! hm - re_cloud=re_cloud, & - re_ice=re_ice, & - re_snow=re_snow, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - 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 & - ) - ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2momccn') - ENDIF ! CASE (GSFCGCESCHEME) CALL wrf_debug ( 100 , 'microphysics_driver: calling GSFCGCE' ) @@ -2593,9 +2333,14 @@ SUBROUTINE microphysics_driver( & ,has_reqc=has_reqc & ! for radiation + ,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 & ,re_cloud=re_cloud & ,re_ice=re_ice & ,re_snow=re_snow & ! for radiation - + ,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 & diff --git a/phys/module_mp_SBM_polar_radar.F b/phys/module_mp_SBM_polar_radar.F index 4f94129271..a6ba4e4cc1 100644 --- a/phys/module_mp_SBM_polar_radar.F +++ b/phys/module_mp_SBM_polar_radar.F @@ -6,6 +6,11 @@ SUBROUTINE SBM_polar_radar dummy = 1 END SUBROUTINE SBM_polar_radar END MODULE module_mp_SBM_polar_radar + +! Stub module +module scatt_tables +end module scatt_tables + #else !****************** module scatt_tables diff --git a/phys/module_mp_fast_sbm.F b/phys/module_mp_fast_sbm.F index 184a9220ea..eb74e0aa1c 100644 --- a/phys/module_mp_fast_sbm.F +++ b/phys/module_mp_fast_sbm.F @@ -6,6 +6,20 @@ SUBROUTINE SBM_fast dummy = 1 END SUBROUTINE SBM_fast END MODULE module_mp_fast_sbm + +! Stub modules +module module_mp_SBM_BreakUp +end module module_mp_SBM_BreakUp + +module module_mp_SBM_Collision +end module module_mp_SBM_Collision + +module module_mp_SBM_Auxiliary +end module module_mp_SBM_Auxiliary + +module module_mp_SBM_Nucleation +end module module_mp_SBM_Nucleation + #else ! +-----------------------------------------------------------------------------+ ! +-----------------------------------------------------------------------------+ @@ -4096,7 +4110,7 @@ SUBROUTINE FAST_SBM (w,u,v,th_old, & REAL (KIND=R8SIZE) :: DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN REAL (KIND=R8SIZE) :: DELSUP1,DELSUP2,DELDIV1,DELDIV2 REAL (KIND=R8SIZE) :: TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ - REAL (KIND=R8SIZE) :: DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD + REAL (KIND=R8SIZE) :: DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD,DEL_T,DEL_Q REAL (KIND=R4SIZE) :: DEL_BB,DEL_BBN,DEL_BBR, TTA_r REAL (KIND=R4SIZE) :: FACTZ,CONCCCN_XZ,CONCDROP REAL (KIND=R4SIZE) :: SUPICE(KTE),AR1,AR2, & @@ -4594,26 +4608,12 @@ SUBROUTINE FAST_SBM (w,u,v,th_old, & SUP2_OLD=DEL2IN IF(del1ad > 0.0 .or. del2ad > 0.0 .or. (sum(FF1R)+sum(FF3R)+sum(FF4R)+sum(FF5R)) > 1.0e-20)THEN - ! JacobS: commented for this version - ! CALL Relaxation_Time(TT,QQ,PP,rhocgs(I,K,J),DEL1IN,DEL2IN, & - ! XL,VR1_Z(:,K),FF1R,RLEC,RO1BL, & - ! XI,VR2_Z,FF2R,RIEC,RO2BL, & - ! XS,VR3_Z(:,K),FF3R,RSEC,RO3BL, & - ! XG,VR4_Z(:,K),FF4R,RGEC,RO4BL, & - ! XH,VR5_Z(:,k),FF5R,RHEC,RO5BL, & - ! NKR,ICEMAX,COL,DT,NCOND,DTCOND) - DELSUP1=(DEL1AD-DEL1IN)/NCOND - DELSUP2=(DEL2AD-DEL2IN)/NCOND - DELDIV1=(DIV3-DIV1)/NCOND - DELDIV2=(DIV4-DIV2)/NCOND - DELTATEMP = 0 - DELTAQ = 0 - tt_old = TT - qq_old = qq - DIFFU=1 - - IF (DIV1.EQ.DIV3) DIFFU = 0 - IF (DIV2.EQ.DIV4) DIFFU = 0 + DEL_T = (TTA - TT) / NCOND + DEL_Q = (QQA - QQ) / NCOND + + DIFFU=1 + IF (DIV1.EQ.DIV3) DIFFU = 0 + IF (DIV2.EQ.DIV4) DIFFU = 0 DTNEW = 0.0 DO IKL=1,NCOND @@ -4622,27 +4622,20 @@ SUBROUTINE FAST_SBM (w,u,v,th_old, & IF (DIFFU.NE.0)THEN IF (DIFFU.NE.0)THEN - DEL1IN = DEL1IN+DELSUP1 - DEL2IN = DEL2IN+DELSUP2 - DIV1 = DIV1+DELDIV1 - DIV2 = DIV2+DELDIV2 + TT = TT + DEL_T + QQ = QQ + DEL_Q + ES1N = AA1_MY*DEXP(-BB1_MY/TT) + ES2N = AA2_MY*DEXP(-BB2_MY/TT) + EW1N = QQ*PP/(0.622+0.378*QQ) + DIV1 = EW1N/ES1N + DEL1IN = EW1N/ES1N-1.0 + DIV2 = EW1N/ES2N + DEL2IN = EW1N/ES2N-1.0 END IF IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN DIFFU=0 END IF IF (DIFFU == 1)THEN - DEL1NR=A1_MYN*(100.*DIV1) - DEL2NR=A2_MYN*(100.*DIV2) - IF (DEL2NR.EQ.0)print*,'ikl = ',ikl - IF (DEL2NR.EQ.0)print*,'div1,div2 = ',div1,div2 - IF (DEL2NR.EQ.0)print*,'i,j,k = ',i,j,k - IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2NR.EQ.0) , model stop ") - DEL12R=DEL1NR/DEL2NR - DEL12RD=DEL12R**DEL_BBR - EW1PN=AA1_MY*100.*DIV1*DEL12RD/100. - TT=-DEL_BB/DLOG(DEL12R) - QQ=0.622*EW1PN/(PP-0.378*EW1PN) - IF(DEL1IN > 0.0 .OR. DEL2IN > 0.0)THEN ! +------------------------------------------+ ! Droplet nucleation : @@ -6688,26 +6681,26 @@ SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & FF2(KR,ICE) = 0.0 ELSE IF (KR .gt. 10 .and. KR .lt. 18) THEN meltrate = 0.5/50. + ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) - ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) ELSE meltrate = 0.683/120. + ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) - ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) ENDIF ENDIF IF (ICE ==2 .or. ICE ==3) THEN IF (kr .le. 12) THEN + ARG_M = ARG_M+FF2(KR,ICE) FF2(KR,ICE)=0. - ARG_M = ARG_M+FF2(KR,ICE) ELSE IF (kr .gt. 12 .and. kr .lt. 20) THEN meltrate = 0.5/50. + ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) - ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) ELSE - meltrate = 0.683/120. + meltrate = 0.683/120. + ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) - ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) ENDIF ENDIF END DO ! Do ice @@ -6717,12 +6710,12 @@ SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & FF3(KR) = 0.0 ELSE IF (kr .gt. 14 .and. kr .lt. 22) THEN meltrate = 0.5/50. - FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt) ARG_M=ARG_M+FF3(KR)*(meltrate*dt) + FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt) ELSE meltrate = 0.683/120. - FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt) ARG_M=ARG_M+FF3(KR)*(meltrate*dt) + FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt) ENDIF ! ... Graupel/Hail IF (kr .le. 13) then @@ -6731,14 +6724,14 @@ SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & FF5(KR)=0. ELSE IF (kr .gt. 13 .and. kr .lt. 23) THEN meltrate = 0.5/50. + ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt) FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt) FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt) - ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt) ELSE meltrate = 0.683/120. - FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt) - FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt) - ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt) + ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt) + FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt) + FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt) ENDIF FF1(KR) = FF1(KR) + ARG_M @@ -7077,26 +7070,6 @@ SUBROUTINE ONECOND1 & call wrf_error_fatal("fatal error in ONECOND1-in (ABS(DAL1*DELMASSL1) > 3.0), model stop") ENDIF - ! ... SUPERSATURATION (ONLY WATER) - ARGEXP=-BB1_MY/TPN - ES1N=AA1_MY*DEXP(ARGEXP) - ARGEXP=-BB2_MY/TPN - ES2N=AA2_MY*DEXP(ARGEXP) - EW1N=OPER3(QPN,PP) - IF(ES1N == 0.0D0)THEN - DEL1N=0.5 - DIV1=1.5 - ELSE - DIV1 = EW1N/ES1N - DEL1N = EW1N/ES1N-1. - END IF - IF(ES2N == 0.0D0)THEN - DEL2N=0.5 - DIV2=1.5 - ELSE - DEL2N = EW1N/ES2N-1. - DIV2 = EW1N/ES2N - END IF IF(ISYM1 == 1) THEN DO KR=1,NKR SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N @@ -7160,29 +7133,6 @@ SUBROUTINE ONECOND1 & ENDIF ENDIF - ! ... SUPERSATURATION - ARGEXP=-BB1_MY/TPN - ES1N=AA1_MY*DEXP(ARGEXP) - ARGEXP=-BB2_MY/TPN - ES2N=AA2_MY*DEXP(ARGEXP) - EW1N=OPER3(QPN,PP) - IF(ES1N == 0.0D0)THEN - DEL1N=0.5 - DIV1=1.5 - call wrf_error_fatal("fatal error in ONECOND1 (ES1N.EQ.0), model stop") - ELSE - DIV1=EW1N/ES1N - DEL1N=EW1N/ES1N-1. - END IF - IF(ES2N.EQ.0)THEN - DEL2N=0.5 - DIV2=1.5 - call wrf_error_fatal("fatal error in ONECOND1 (ES2N.EQ.0), model stop") - ELSE - DEL2N=EW1N/ES2N-1. - DIV2=EW1N/ES2N - END IF - TT=TPN QQ=QPN DO KR=1,NKR @@ -7745,29 +7695,6 @@ SUBROUTINE ONECOND2 & ENDIF ENDIF - ! ... SUPERSATURATION - ARGEXP=-BB1_MY/TPN - ES1N=AA1_MY*DEXP(ARGEXP) - ARGEXP=-BB2_MY/TPN - ES2N=AA2_MY*DEXP(ARGEXP) - EW1N=OPER3(QPN,PP) - IF(ES1N == 0.0)THEN - DEL1N=0.5 - DIV1=1.5 - call wrf_error_fatal("fatal error in ONECOND2 (ES1N.EQ.0), model stop") - ELSE - DIV1=EW1N/ES1N - DEL1N=EW1N/ES1N-1. - END IF - IF(ES2N == 0.0)THEN - DEL2N=0.5 - DIV2=1.5 - call wrf_error_fatal("fatal error in ONECOND2 (ES2N.EQ.0), model stop") - ELSE - DEL2N=EW1N/ES2N-1. - DIV2=EW1N/ES2N - END IF - ! END OF TIME SPLITTING ! (ONLY ICE: CONDENSATION OR EVAPORATION) IF(TIMENEW.LT.DT) GOTO 46 @@ -8312,31 +8239,7 @@ SUBROUTINE ONECOND3 & call wrf_error_fatal("fatal error in ONECOND3-out (ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0), model stop") ENDIF ENDIF - - ! SUPERSATURATION - ARGEXP=-BB1_MY/TPN - ES1N=AA1_MY*DEXP(ARGEXP) - ARGEXP=-BB2_MY/TPN - ES2N=AA2_MY*DEXP(ARGEXP) - EW1N=OPER3(QPN,PP) - IF(ES1N == 0.0)THEN - DEL1N=0.5 - DIV1=1.5 - print*,'es1n onecond3 = 0' - call wrf_error_fatal("fatal error in ONECOND3 (ES1N.EQ.0), model stop") - ELSE - DIV1=EW1N/ES1N - DEL1N=EW1N/ES1N-1. - END IF - IF(ES2N == 0.0)THEN - DEL2N=0.5 - DIV2=1.5 - print*,'es2n onecond3 = 0' - call wrf_error_fatal("fatal error in ONECOND3 (ES2N.EQ.0), model stop") - ELSE - DEL2N=EW1N/ES2N-1. - DIV2=EW1N/ES2N - END IF + ! END OF TIME SPLITTING IF(TIMENEW < DT) GOTO 16 diff --git a/phys/module_mp_nssl_2mom.F b/phys/module_mp_nssl_2mom.F index 10d5f1cd51..d89baf3571 100644 --- a/phys/module_mp_nssl_2mom.F +++ b/phys/module_mp_nssl_2mom.F @@ -1,8 +1,6 @@ !WRF:MODEL_LAYER:PHYSICS - -! prepocessed on "Sep 7 2021" at "19:37:43" - +! prepocessed on "Aug 14 2023" at "16:15:23" @@ -25,35 +23,33 @@ ! ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! -! This module provides a 2-moment bulk microphysics scheme originally -! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in -! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation -! follows Mansell (2010, JAS), using parameter infall = 4. -! -! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) -! -! Average graupel particle density is predicted, which affects fall speed as well. -! Hail density prediction is by default disabled in this version, but may be enabled -! at some point if there is interest. -! -! Maintainer: Ted Mansell, National Severe Storms Laboratory -! -! Microphysics References: -! -! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small -! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. -! -! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and -! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, -! doi:10.1175/JAS-D-12-0264.1. -! -! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. -! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. -! -! Sedimentation reference: -! -! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. -! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. +!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! follows Mansell (2010, JAS), using parameter infall = 4. +!! +!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) +!! +!! Average graupel and hail particle densities are predicted, which affects fall speed as well. +!! +!! Maintainer: Ted Mansell, National Severe Storms Laboratory +!! +!! Microphysics References: +!! +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. +!! +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! doi:10.1175/JAS-D-12-0264.1. +!! +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. +!! +!! Sedimentation reference: +!! +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. ! ! Possible parameters to adjust: ! @@ -66,18 +62,26 @@ ! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The ! implementation of an explicit charging and discharge lightning scheme ! within the WRF-ARW model: Benchmark simulations of a continental squall line, a -! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 ! -! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated ! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 ! ! Note: Some parameters below apply to unreleased features. ! ! !--------------------------------------------------------------------- +! Apr. 2023 (WRF-4.6) +! - Update to 3-moment for rain, graupel, and hail +! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013) +! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds. +! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom, +! using wet growth diameter to convert large graupel +!--------------------------------------------------------------------- ! Sept. 2021: ! Fixes: -! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) ! Other: ! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) ! Reordered collection coefficients (dab1lh) to be consistent (no effect) @@ -169,7 +173,6 @@ MODULE module_mp_nssl_2mom - IMPLICIT NONE public nssl_2mom_driver @@ -212,14 +215,13 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) - integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband - + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband ! microphysics real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params - real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) @@ -232,8 +234,10 @@ MODULE module_mp_nssl_2mom real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) - real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value - real , public :: qccn ! ccn "mixing ratio" + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value + real , public :: qccn, qccnuf ! ccn "mixing ratio" + real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time real , private :: qcwmntim = 1.0e-5 ! 10-ice rain delay min qc for time accrual @@ -242,10 +246,17 @@ MODULE module_mp_nssl_2mom ! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state #else - logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state + logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state #endif + logical :: switchccn = .false. + real :: old_cccn = -1.0 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN + real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018) + real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.) + logical :: decayufccn = .false. + integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn) ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) @@ -254,6 +265,7 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 + integer, private :: isfall = 2 ! default limit with method II (more restrictive) logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. @@ -264,14 +276,20 @@ MODULE module_mp_nssl_2mom ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates) real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) real, private :: icefallfac = 1.0 ! factor to adjust ice fall speed real, private :: snowfallfac = 1.0 ! factor to adjust snow fall speed real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) - integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. - integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + real :: axh = 75.7149, bxh = 0.5 + real :: axf = 75.7149, bxf = 0.5 + real :: axhl = 206.984, bxhl = 0.6384 real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) @@ -305,7 +323,7 @@ MODULE module_mp_nssl_2mom integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds - integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) real , private :: rimc3 = 170.0 ! minimum rime density real :: rimc4 = 900.0 ! maximum rime density @@ -320,7 +338,7 @@ MODULE module_mp_nssl_2mom ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) - integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) ! =2 renucleation following Twomey/Cohard&Pinty ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base @@ -342,6 +360,7 @@ MODULE module_mp_nssl_2mom ! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets) integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version @@ -352,7 +371,9 @@ MODULE module_mp_nssl_2mom integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) @@ -379,9 +400,9 @@ MODULE module_mp_nssl_2mom integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) integer, private :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C integer, private :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C - real , private :: ehw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency + real , private :: ehw0 = 0.9 ! 0.5 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency - real , private :: ehlw0 = 0.75 ! constant or max assumed hail-droplet collection efficiency + real , private :: ehlw0 = 0.9 ! 0.75 ! constant or max assumed hail-droplet collection efficiency real , private :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency @@ -408,15 +429,19 @@ MODULE module_mp_nssl_2mom ! set eii1 = 0 to get a constant value of eii0 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ! set eii1hl = 0 to get a constant value of eii0hl + real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi + real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 - real , private :: ess0 = 1.0, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI + ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 - real , private :: esstem1 = -25. ! lower temperature where snow aggregation turns on - real , private :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 real , private :: essrmax = 0.02 ! maximum snow radius (meters) for csacs real , private :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off real , private :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off @@ -447,11 +472,13 @@ MODULE module_mp_nssl_2mom ! 0 = no condensation on rain; 1 = bulk condensation on rain integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail @@ -475,6 +502,7 @@ MODULE module_mp_nssl_2mom real, private :: qhdpvdn = -1. real, private :: qhacidn = -1. + integer, private :: iraintypes = 0 logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel integer, private :: imixedphase = 0 logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density @@ -506,17 +534,23 @@ MODULE module_mp_nssl_2mom real, parameter :: alpharmax = 8. ! limited for rwvent calculation - integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold + ! 3 = Conversion using wet growth diameter real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) - real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) - real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL + real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. @@ -533,6 +567,8 @@ MODULE module_mp_nssl_2mom ! = 1 use mean diameter for breakup ! = 2 use maximum mass diameter for breakup ! = 3 use mass-weighted diameter for breakup + integer :: iraintailbreak = 0 ! 1 = on + real :: draintail = 8.e-3 ! starting size for rain breakup integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) @@ -540,7 +576,7 @@ MODULE module_mp_nssl_2mom ! = 2 DTD mass-weighted version based on MY code ! = 3 Milbrandt version (from Cohard and Pinty code integer :: dmropt = 0 ! extra option for crcnw - integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: dmhlopt = 0 ! options for graupel -> hail conversion integer :: irescalerainopt = 3 ! 0 = default option ! 1 = qx(mgs,lc) > qxmin(lc) ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 @@ -557,6 +593,7 @@ MODULE module_mp_nssl_2mom integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting ! when liquid fraction is not predicted + logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters ! 1 = original Zrnic et al. (Mansell et al. 2010) @@ -589,9 +626,12 @@ MODULE module_mp_nssl_2mom integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0 + integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0 real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) @@ -602,6 +642,7 @@ MODULE module_mp_nssl_2mom ! 3 = only add 1.5*cxmin to number concentration (allow max size to apply) ! 4 = add droplets with minimum radius of 20 microns real :: maxsupersat = 1.9 ! maximum supersaturation ratio, above which a saturation adustment is done + real :: maxlowtempss = 1.08 ! Sat. ratio threshold for allowing droplet nucleation at T < tfrh real :: ssmxuf = 4.0 ! supersaturation at which to start using "ultrafine" CCN (if ccnuf > 0.) @@ -732,6 +773,7 @@ MODULE module_mp_nssl_2mom real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 real bb (lc:lqmx) + ! put ipelec here for now.... integer :: ipelec = 0 integer :: isaund = 0 @@ -757,8 +799,8 @@ MODULE module_mp_nssl_2mom double precision, parameter :: dgam = 0.01, dgami = 100. double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) - integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 - integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 + integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25 ! real, parameter :: maxratiolu = 25. real, parameter :: maxratiolu = 100. ! 25. real, parameter :: maxalphalu = 15. @@ -775,6 +817,10 @@ MODULE module_mp_nssl_2mom ! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) ! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! for 3-moment collection coefficients + real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail @@ -810,7 +856,6 @@ MODULE module_mp_nssl_2mom ! ! constants ! - real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv real, parameter :: ar = 841.99666 ! rain terminal velocity power law coefficient (LFO) real, parameter :: br = 0.8 ! rain terminal velocity power law coefficient (LFO) real, parameter :: aradcw = -0.27544 ! @@ -827,12 +872,14 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv + + real, parameter :: gr = 9.8 + real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 - real, parameter :: gr = 9.8 - ! ! max and min mean volumes ! @@ -853,7 +900,7 @@ MODULE module_mp_nssl_2mom ! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius - real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 @@ -895,25 +942,28 @@ MODULE module_mp_nssl_2mom real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation real, parameter :: cawbolton = 17.67 - real, parameter :: tfr = 273.15, tfrh = 233.15 + real, parameter :: tfrh = 233.15 + real, parameter :: tfr = 273.15 real, parameter :: cp = 1004.0, rd = 287.04 - real, parameter :: cpi = 1./cp - real, parameter :: cap = rd/cp, poo = 1.0e+05 - real, parameter :: rw = 461.5 ! gas const. for water vapor + real, parameter :: cpl = 4190.0 + real, parameter :: cpigb = 2106.0 + real, parameter :: cpi = 1./cp + real, parameter :: cap = rd/cp + real, parameter :: tfrcbw = tfr - cbw + real, parameter :: tfrcbi = tfr - cbi + real, parameter :: rovcp = rd/cp + real :: rdorv = 0.622 + real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc real, parameter :: tka0 = 2.43e-02 ! reference thermal conductivity - real, parameter :: tfrcbw = tfr - cbw - real, parameter :: tfrcbi = tfr - cbi ! GHB: Needed for eqtset=2 in cm1 ! REAL, PRIVATE :: cv = cp - rd - real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air - REAL, PRIVATE, parameter :: cvv = 1408.5 - REAL, PRIVATE, parameter :: cpl = 4190.0 - REAL, PRIVATE, parameter :: cpigb = 2106.0 + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 ! GHB real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) @@ -942,10 +992,12 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. + integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only) + logical, private :: nuaccoinp = .false. ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. -! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & ndebug, ncdebug,& @@ -955,7 +1007,7 @@ MODULE module_mp_nssl_2mom idbzci, & vtmaxsed, & itfall,iscfall, & - infall, & + infall,irfall,isfall, & rssflg, & sssflg, & hssflg, & @@ -966,12 +1018,15 @@ MODULE module_mp_nssl_2mom icnuclimit, & irenuc, & restoreccn, ccntimeconst, cck, & + decayufccn, ufccntimeconst, & + switchccn, old_cccn, & ciintmx, & itype1, itype2, & - icenucopt, & + icenucopt, in_freeze_rain_first, & naer, & icfn, & ibfc, iacr, icracr, & + icracrthresh, & cwfrz2snowfrac, cwfrz2snowratio, & ibfr, & ibiggopt, & @@ -987,7 +1042,7 @@ MODULE module_mp_nssl_2mom eri_cimin, & eii0hl, eii1hl, & ehs0, ehs1, & - ess0, ess1, & + ess0, ess1, iessopt, & esstem1,esstem2, & ircnw, qminrncw,& ! single-moment only iglcnvi, & @@ -1013,6 +1068,7 @@ MODULE module_mp_nssl_2mom hailfallfac, & icefallopt, & icdx,icdxhl, & + axh,bxh,axf,bxf,axhl,bxhl, & cdhmin, cdhmax, & cdhdnmin, cdhdnmax, & cdhlmin, cdhlmax, & @@ -1047,7 +1103,7 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1080,7 +1136,6 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & - charging_border, & do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1106,10 +1161,10 @@ END FUNCTION fqis -! ##################################################################### -! ##################################################################### +! ##################################################################### +! ##################################################################### SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & & nssl_graupelfallfac, & @@ -1119,7 +1174,15 @@ SUBROUTINE nssl_2mom_init( & & nssl_icdx, & & nssl_icdxhl, & & nssl_icefallfac, & - & nssl_snowfallfac & + & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_ufccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar, & + & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & + & infileunit, & + & myrank, mpiroot & ) implicit none @@ -1130,21 +1193,35 @@ SUBROUTINE nssl_2mom_init( & & nssl_ehw0, & & nssl_ehlw0, & & nssl_icefallfac, & - & nssl_snowfallfac + & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar integer, intent(in), optional :: & & nssl_icdx, & - & nssl_icdxhl + & nssl_icdxhl, myrank, mpiroot, & + & nssl_ufccn + logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + integer, intent(inout), optional :: ccn_is_ccna - integer, intent(in) :: ims,ime, jms,jme, kms,kme - real, intent(in), dimension(20) :: nssl_params + integer, intent(in),optional :: infileunit + integer, intent(in), optional :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20), optional :: nssl_params - integer, intent(in) :: ipctmp,mixphase,ihvol + + + integer, intent(in) :: ipctmp,mixphase + integer, optional, intent(in) :: ihvol logical, optional, intent(in) :: idoniconlytmp + integer :: igvol_local = 1 logical :: wrote_namelist = .false. logical :: wrf_dm_on_monitor + integer :: hail_on = -1, density_on = -1, icecrystals_on = 1 + integer :: ccn_on = -1 double precision :: arg real :: temq @@ -1152,20 +1229,57 @@ SUBROUTINE nssl_2mom_init( & integer :: i,il,j,l integer :: ltmp integer :: isub - real :: bxh,bxhl + real :: bxh1,bxhl1 real :: alp,ratio double precision :: x,y,y2,y7 logical :: turn_on_ccna, turn_on_cina + integer :: iufccn = 0 integer :: istat + + real :: alpjj, alpii, xnuii, xnujj + integer :: ii, jj turn_on_ccna = .false. turn_on_cina = .false. + +! IF ( present( igvol ) ) THEN +! igvol_local = igvol +! ENDIF + + IF ( present( nssl_hail_on ) ) THEN + IF ( nssl_hail_on ) THEN + hail_on = 1 + ELSE + hail_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_density_on ) ) THEN + IF ( nssl_density_on ) THEN + density_on = 1 + ELSE + density_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_icecrystals_on ) ) THEN + IF ( nssl_icecrystals_on ) THEN + icecrystals_on = 1 + ELSE + icecrystals_on = 0 + ! renucfrac = 1.0 ! why was this set to 1? + ffrzs = 1.0 + ENDIF + ENDIF + + ! ! set some global values from namelist input ! + IF ( present( nssl_params ) ) THEN ccn = Abs( nssl_params(1) ) alphah = nssl_params(2) alphahl = nssl_params(3) @@ -1176,36 +1290,77 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) - + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + ccnuf = Abs( nssl_params(14) ) + IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn + + ENDIF ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) + + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac - IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 - IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_ehw0) ) THEN + IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0 + ENDIF + IF ( present(nssl_ehlw0) ) THEN + IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0 + ENDIF IF ( present(nssl_icdx) ) icdx = nssl_icdx IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + IF ( present(nssl_cccn) ) THEN + IF (nssl_cccn > 1 ) ccn = nssl_cccn + ENDIF + IF ( present(nssl_alphah) ) THEN + IF ( nssl_alphah > -1. ) alphah = nssl_alphah + ENDIF + IF ( present(nssl_alphahl) ) THEN + IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl + ENDIF + IF ( present(nssl_alphar) ) THEN + IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar + ENDIF - IF ( Nint(nssl_params(13)) == 1 ) THEN - ! hack to switch CCN field to CCNA (activated ccn) -! invertccn = .true. - turn_on_ccna = .true. - irenuc = 7 + ipconc = ipctmp + + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ENDIF + + IF ( ihlcnh <= 0 ) THEN + IF ( ipconc == 5 ) THEN + ihlcnh = 3 + ELSEIF ( ipconc >= 6 ) THEN + ihlcnh = 3 ENDIF + ENDIF - IF ( .false. ) THEN ! set to true to enable internal namelist read + + IF ( .true. ) THEN ! set to true to enable internal namelist read open(15,file='namelist.input',status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) close(15) IF ( istat /= 0 ) THEN - write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' +#ifdef WRF_ELEC + IF ( wrf_dm_on_monitor() ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF +#else + ! write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' +#endif ENDIF IF ( wrf_dm_on_monitor() .and. .not. wrote_namelist ) THEN open(15,file='namelist.output',status='old',action='readwrite', position='append',form='formatted') @@ -1217,8 +1372,42 @@ SUBROUTINE nssl_2mom_init( & + IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn + irenuc = 7 + IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay + IF ( i_uf_or_ccn > 0 ) THEN + ufbackground = 0.0 + ccntimeconst = ufccntimeconst + ENDIF + ENDIF + + IF ( present( nssl_ccn_on ) ) THEN + IF ( nssl_ccn_on ) THEN + ccn_on = 1 + ELSE + ccn_on = 0 + irenuc = 2 + ENDIF + ENDIF + IF ( irenuc >= 5 ) THEN turn_on_ccna = .true. + IF ( present( nssl_ccn_on ) ) THEN + IF ( .not. nssl_ccn_on ) THEN + write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + STOP + ENDIF + ENDIF + ENDIF + + IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN + IF ( ccn_is_ccna > 0 ) THEN + turn_on_ccna = .true. + ELSE + IF ( irenuc >= 5 ) THEN + ccn_is_ccna = 1 + ENDIF + ENDIF ENDIF cwccn = ccn @@ -1232,24 +1421,41 @@ SUBROUTINE nssl_2mom_init( & lh = lh + 1 lhl = lhl + 1 ENDIF - IF ( ihvol <= -1 .or. ihvol == 2 ) THEN - IF ( ihvol == -1 .or. ihvol == -2 ) THEN - lhab = lhab - 1 ! turns off hail - lhl = 0 - ! past me thought it would be a good idea to change graupel factors when hail is off.... - ! ehw0 = 0.75 - ! iehw = 2 - ! dfrz = Max( dfrz, 0.5e-3 ) - ENDIF - IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off - ! a value of -3 means to turn off ice crystals but turn on hail - renucfrac = 1.0 - ffrzs = 1.0 - ! idoci = 0 ! try this later + IF ( hail_on == -1 ) THEN ! hail_on is not set + hail_on = 1 + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + hail_on = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off + ! a value of 2? means to turn off ice crystals but turn on hail + ! renucfrac = 1.0 ! why? + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + ELSE ! hail_on is set + IF ( hail_on == 0 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ELSE + ! assume default that hail is on ENDIF ENDIF + + IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it + density_on = 1 + ENDIF + -! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl +! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on ! IF ( ipelec > 0 ) idonic = .true. @@ -1276,29 +1482,42 @@ SUBROUTINE nssl_2mom_init( & bx(lr) = 0.85 ax(lr) = 1647.81 fx(lr) = 135.477 + IF ( icdx == 6 ) THEN bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. ax(lh) = 157.71 - ELSEIF ( icdx > 0 ) THEN +! ELSEIF ( icdx == 1 ) THEN +! bx(lh) = bxh +! ax(lh) = axh + ELSEIF ( icdx > 1 ) THEN bx(lh) = 0.5 ax(lh) = 75.7149 - ELSE - bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ELSEIF ( icdx == 0 ) THEN + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel ax(lh) = 19.3 + ELSE ! icdx < 0 +! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops +! bx(lh) = 0.6384 + bx(lh) = bxh + ax(lh) = axh ENDIF + ! bx(lh) = 0.6 IF ( lhl .gt. 1 ) THEN IF ( icdxhl == 6 ) THEN bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. ax(lhl) = 179.36 + ELSEIF (icdxhl == 0 ) THEN + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 ELSEIF (icdxhl > 0 ) THEN - bx(lhl) = 0.5 - ax(lhl) = 75.7149 + bx(lhl) = 0.5 + ax(lhl) = 75.7149 ELSE - ax(lhl) = 206.984 ! Ferrier 1994 - bx(lhl) = 0.6384 + bx(lhl) = bxhl + ax(lhl) = axhl ENDIF ENDIF @@ -1314,8 +1533,8 @@ SUBROUTINE nssl_2mom_init( & ! Uses incomplete gamma functions ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) - bxh = bx(lh) - bxhl = bx(Max(lh,lhl)) + bxh1 = bx(lh) + bxhl1 = bx(Max(lh,lhl)) ! DO j = 0,nqiacralpha DO j = ialpstart,nqiacralpha @@ -1331,9 +1550,9 @@ SUBROUTINE nssl_2mom_init( & ! graupel (.,.,.,1) gamxinflu(i,j,1,1) = x/y gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y - gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y - gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y @@ -1342,9 +1561,9 @@ SUBROUTINE nssl_2mom_init( & ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) - gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) - gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) @@ -1352,16 +1571,16 @@ SUBROUTINE nssl_2mom_init( & ! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y ! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y -! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y ELSE ! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y -! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y -! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y - gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y ENDIF gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) @@ -1395,9 +1614,8 @@ SUBROUTINE nssl_2mom_init( & qiacrratio(0,:) = 1.0 - isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 - lccn = 0 + lccnuf = 0 lccna = 0 lnc = 0 lnr = 0 @@ -1419,34 +1637,41 @@ SUBROUTINE nssl_2mom_init( & ! lccn = 9 - ipconc = ipctmp IF ( ipconc == 0 ) THEN - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme lvh = 9 ltmp = 9 denscale(lvh) = 1 - ELSE ! no hail + ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 ENDIF ELSEIF ( ipconc == 5 ) THEN - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( density_on >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off ! ltmp = lvh - denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN + ENDIF + denscale(lccn:ltmp) = 1 + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1464,24 +1689,31 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN - write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' - STOP - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh IF ( lhl > 0 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( density_on == 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off + ENDIF ! ltmp = lvh - denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN + denscale(lccn:ltmp) = 1 + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1501,19 +1733,14 @@ SUBROUTINE nssl_2mom_init( & lzh = ltmp ltmp = ltmp + 1 lzr = ltmp - ltmp = ltmp + 1 IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp ENDIF + ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl ENDIF ! ltmp = lvh ! denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN - lvhl = ltmp+1 - ltmp = lvhl - denscale(lvhl) = 1 - ENDIF IF ( mixedphase ) THEN ltmp = ltmp + 1 lsw = ltmp @@ -1531,7 +1758,8 @@ SUBROUTINE nssl_2mom_init( & - + ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl + ! write(0,*) 'wrf_init: ipconc = ',ipconc ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna IF ( turn_on_ccna ) THEN ltmp = ltmp + 1 @@ -1763,9 +1991,16 @@ SUBROUTINE nssl_2mom_init( & IF ( lhl .gt. 1 ) ido(lhl) = idohl IF ( irfall .lt. 0 ) irfall = infall + IF ( isfall .lt. 0 ) isfall = infall IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 + qccnuf = ccnuf/rho00 + IF ( old_cccn > 0.0 ) THEN + old_qccn = old_cccn/rho00 + ELSE + old_qccn = qccn + ENDIF ! xvcmx = (4./3.)*pi*xcradmx**3 ! set max rain diameter @@ -1914,6 +2149,33 @@ SUBROUTINE nssl_2mom_init( & ENDDO ENDDO + dab0lu(:,:,:,:) = 0.0 + dab1lu(:,:,:,:) = 0.0 + + IF ( ipconc >= 6 ) THEN + DO il = lc,lhab ! collector + DO j = lc,lhab ! collected + IF ( il .ne. j ) THEN + + DO jj = ialpstart,nqiacralpha + alpjj = float(jj)*dqiacralpha + xnujj = (alpjj - 2.)/3. + DO ii = ialpstart,nqiacralpha + alpii = float(ii)*dqiacralpha + xnuii = (alpii - 2.)/3. + + dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0) + dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1) + + ENDDO + ENDDO +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + ENDIF + gf4br = gamma_sp(4.0+br) gf4ds = gamma_sp(4.0+ds) gf4p5 = gamma_sp(4.0+0.5) @@ -1960,24 +2222,31 @@ END SUBROUTINE nssl_2mom_init ! ##################################################################### SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & - zrw, zhw, zhl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & + cnuf, f_cnuf, & + zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & + is_theta_or_temp, & + ntmul, ntcnt, lastloop, & RAINNC,RAINNCV, & dx, dy, & axtra, & SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & + hail_maxk1, hail_max2d, nwp_diagnostics, & tkediss, & - re_cloud, re_ice, re_snow, & - has_reqc, has_reqi, has_reqs, & + re_cloud, re_ice, re_snow, re_rain, & + re_graup, re_hail, & + has_reqc, has_reqi, has_reqs, has_reqr, & + has_reqg, has_reqh, & rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & - induc,elec,scion,sciona, & + induc,elecz,scion,sciona, & noninduc,noninducp,noninducn, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & @@ -2004,6 +2273,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + implicit none @@ -2021,7 +2292,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + integer, optional, intent(in) :: is_theta_or_temp + logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2032,8 +2305,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez - real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii @@ -2054,29 +2327,44 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra ! WRF variables - real, dimension(ims:ime, jms:jme), intent(inout):: & + real, dimension(ims:ime, jms:jme) :: & RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d + integer, optional, intent(in) :: nwp_diagnostics +! for cm1, set nproctot=44 (or as needed) to get domain total rates + integer, parameter :: nproc = 1 + double precision :: proctot(nproc),proctotmpi(nproc) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, & + re_rain, re_graup, re_hail REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss - INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype - logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, intent(in), optional :: ntmul, ntcnt + logical, optional, intent(in) :: lastloop + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf + logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl integer, optional, intent(in) :: ipelectmp, ke_diag + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag_cnuf = .false. + logical :: flag_ccn = .false. + logical :: flag_qi = .true. + logical :: has_reqr_local = .false., has_reqg_local = .false., has_reqh_local = .false. logical :: flag + logical :: nwp_diagflag = .false. real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2101,11 +2389,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall + real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1 + real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 - integer :: nx,ny,nz + integer :: nx,ny,nz,ngs integer ix,jy,kz,i,j,k,il,n integer :: infdo real :: ssival, ssifac, t8s, t9s, qvapor @@ -2116,6 +2407,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: dbzmx,refl integer :: vzflag0 = 0 logical :: makediag + real :: dx1,dy1 real, parameter :: cnin20 = 1.0e3 real, parameter :: cnin10 = 5.0e1 real, parameter :: cnin1a = 4.5 @@ -2129,7 +2421,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: grmass1,grmass2 double precision :: hlmass1,hlmass2 double precision :: wvol5,wvol10 - real :: tmp,dv,dv1 + real :: tmp,dv,dv1,tmpchg real :: rdt double precision :: dt1,dt2 @@ -2144,15 +2436,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) - -#ifdef MPI - -#if defined(MPI) - integer, parameter :: ntot = 50 - double precision mpitotindp(ntot), mpitotoutdp(ntot) - INTEGER :: mpi_error_code = 1 -#endif -#endif + + logical, parameter :: debugdriver = .false. + + integer :: loopcnt, loopmax, outerloopcnt + logical :: lastlooptmp ! ------------------------------------------------------------------- @@ -2160,18 +2448,58 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rdt = 1.0/dtp -! write(0,*) 'N2M: entering routine' + IF ( debugdriver ) write(0,*) 'N2M: entering routine' flag_qndrop = .false. flag_qnifa = .false. flag_qnwfa = .false. + flag_cnuf = .false. + flag_ccn = .false. + nwp_diagflag = .false. IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf + IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 ) + IF ( present ( f_cn ) .and. present( cn ) ) THEN + flag_ccn = f_cn + ELSEIF ( present( cn ) ) THEN + flag_ccn = .true. + ENDIF + + IF ( present( f_qi ) ) THEN + flag_qi = f_qi + ELSE + IF ( ffrzs < 1.0 ) THEN + flag_qi = .true. + ELSE + flag_qi = .false. + ENDIF + ENDIF + IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0 + + IF ( PRESENT ( has_reqr ) ) has_reqr_local = has_reqr > 0 + IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0 + IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0 - ! --- + loopmax = 1 + outerloopcnt = 1 + lastlooptmp = .true. + IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN + loopmax = ntmul + outerloopcnt = ntcnt + lastlooptmp = lastloop + ENDIF + + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + ENDIF + ENDIF IF ( present( f_cna ) ) THEN f_cnatmp = f_cna @@ -2202,25 +2530,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDDO ! ENDIF + IF ( present( dx ) .and. present( dy ) ) THEN + dx1 = dx + dy1 = dy + ELSE + dx1 = 1.0 + dy1 = 1.0 + ENDIF + makediag = .true. IF ( present( diagflag ) ) THEN makediag = diagflag .or. itimestep == 1 ENDIF -! write(0,*) 'N2M: makediag = ',makediag + IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag nx = ite-its+1 ny = 1 ! set up as 2D slabs nz = kte-kts+1 + ngs = 64 - IF ( .not. present( cn ) ) THEN + IF ( .not. flag_ccn ) THEN renucfrac = 1.0 ENDIF + ! set up CCN array and some other static local values - IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN + IF ( itimestep == 1 .and. .not. invertccn .and. flag_ccn ) THEN ! this is not needed for WRF 3.8 and later because it is done in physics_init, ! but kept for backwards compatibility with earlier versions IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN @@ -2242,9 +2580,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ENDIF + + IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN +! write(0,*) 'set cnuf1' + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cnuf(ix,kz,jy) = qccnuf + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF - IF ( itimestep == 1 .and. invertccn .and. present( cn ) ) THEN + IF ( itimestep == 1 .and. invertccn .and. flag_ccn ) THEN ! this is not needed for WRF 3.8 and later because it is done in physics_init, ! but kept for backwards compatibility with earlier versions DO jy = jts,jte @@ -2256,7 +2606,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF - IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to + IF ( invertccn .and. flag_ccn ) THEN ! hack for WRF to convert activated ccn to unactivated, then do not have to ! worry about initial and boundary conditions - they are zero DO jy = jts,jte DO kz = kts,kte @@ -2265,7 +2615,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ENDDO + + IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN +! write(0,*) 'set cnuf (invertccn)' + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cnuf(ix,kz,jy) = qccnuf - cnuf(ix,kz,jy) + ENDDO + ENDDO + ENDDO ENDIF + + ENDIF + ! ENDIF ! itimestep == 1 @@ -2316,32 +2679,36 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw -! write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 + thproclocal(:,:) = 0.0 + DO jy = jts,jye - xfall(:,:,:) = 0.0 - ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn IF ( present( pcc2 ) .and. makediag ) THEN axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF + IF ( nwp_diagflag ) THEN + alpha2d(its:ite,1,kts:kte,1) = alphar + alpha2d(its:ite,1,kts:kte,2) = alphah + alpha2d(its:ite,1,kts:kte,3) = alphahl + ENDIF + + ! copy from 3D array to 2D slab DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,lt) = th(ix,kz,jy) - - an(ix,1,kz,lv) = qv(ix,kz,jy) an(ix,1,kz,lc) = qc(ix,kz,jy) an(ix,1,kz,lr) = qr(ix,kz,jy) - IF ( present( qi ) ) THEN + IF ( flag_qi ) THEN an(ix,1,kz,li) = qi(ix,kz,jy) ELSE an(ix,1,kz,li) = 0.0 @@ -2352,13 +2719,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN ! - ELSEIF ( present( cn ) ) THEN + ELSEIF ( flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,kz,jy) an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) ELSE an(ix,1,kz,lccn) = cn(ix,kz,jy) ENDIF + IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn + an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy) + ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) @@ -2369,6 +2739,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ELSE ! UF were added to lccn + an(ix,1,kz,lccnuf) = 0.0 + ENDIF + ENDIF + IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN an(ix,1,kz,lccna) = cna(ix,kz,jy) @@ -2399,12 +2777,42 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale + IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale + IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale + ENDIF + ENDDO + ENDDO + + DO kz = kts,kte + DO ix = its,ite t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + ENDDO + ENDDO + + DO ix = its,ite + RAINNCV(ix,jy) = 0.0 + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0 + IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0 + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0 + ENDDO + + DO loopcnt = 1,loopmax + + DO kz = kts,kte + DO ix = its,ite + + t1(ix,1,kz) = 0.0 t2(ix,1,kz) = 0.0 t3(ix,1,kz) = 0.0 @@ -2414,14 +2822,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t7(ix,1,kz) = 0.0 t8(ix,1,kz) = 0.0 t9(ix,1,kz) = 0.0 - t00(ix,1,kz) = 380.0/p(ix,kz,jy) - t77(ix,1,kz) = pii(ix,kz,jy) - dbz2d(ix,1,kz) = 0.0 - vzf2d(ix,1,kz) = 0.0 - dn1(ix,1,kz) = dn(ix,kz,jy) pn(ix,1,kz) = p(ix,kz,jy) wn(ix,1,kz) = w(ix,kz,jy) + dn1(ix,1,kz) = dn(ix,kz,jy) ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,kz,jy) dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) @@ -2439,6 +2843,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + if ( ssival .gt. 1.0 ) then ! IF ( icenucopt == 1 ) THEN @@ -2491,19 +2896,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 - IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 ! naer needs units of cm**-3, so mult by 1.e-6 - ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - t7(ix,jy,kz) = Min(dp1, 1.0d30) + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + tmp = 1.e-6*naer + dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + t7(ix,1,kz) = Min(dp1, 1.0d30) ELSE - t7(ix,jy,kz) = 0.0 + ! t7(ix,1,kz) = 0.0 ENDIF ENDIF ! icenucopt @@ -2516,48 +2922,48 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ix ENDDO ! kz - has_wetscav = .false. - IF ( wrfchem_flag > 0 ) THEN - IF ( PRESENT( wetscav_on ) ) THEN - has_wetscav = wetscav_on - IF ( has_wetscav ) THEN - IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 - IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 - ENDIF - ENDIF - ENDIF + IF ( wrfchem_flag > 0 ) THEN + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF ! transform from number mixing ratios to number conc. + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF ENDDO ! il + ENDIF + ! sedimentation xfall(:,:,:) = 0.0 - IF ( .true. ) THEN + +! IF ( .true. ) THEN ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 ) THEN + IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF ! #endif IF ( present(cu_used) .and. & ( present( qrcuten ) .or. present( qscuten ) .or. & - present( qicuten ) .or. present( qccuten ) ) ) THEN + present( qicuten ) .or. present( qccuten ) ) ) THEN !{ - IF ( cu_used == 1 ) THEN + IF ( cu_used == 1 ) THEN !{ DO kz = kts,kte DO ix = its,ite @@ -2571,10 +2977,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) - - ENDIF - - ENDIF + DO kz = kts,kte + DO ix = its,ite + + + IF ( ipconc >= 6 ) THEN +! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr) + ENDIF + + ENDDO + ENDDO + + ENDIF !} + + ENDIF !} + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & @@ -2584,14 +3002,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! copy xfall to appropriate places... -! write(0,*) 'N2M: end sediment, jy = ',jy + IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy DO ix = its,ite IF ( lhl > 1 ) THEN - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only @@ -2606,11 +3026,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF ENDIF - IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) - IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) - RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) THEN + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + ENDIF + ENDIF + IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN + SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + ENDIF IF ( lhl > 1 ) THEN !#ifdef CM1 ! IF ( .true. ) THEN @@ -2618,13 +3046,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( HAILNC ) ) THEN !#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) - HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) - ELSEIF ( present( GRPLNCV ) ) THEN - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) +! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel +! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF - IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) - IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN + GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + ENDIF + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN IF ( present( HAILNC ) ) THEN SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ELSE @@ -2633,12 +3063,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDDO - ENDIF ! .false. +! ENDIF ! .false. IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics -! write(0,*) 'N2M: gs, jy = ',jy + IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy ! IF ( isedonly /= 2 ) THEN @@ -2655,8 +3085,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,tke2d, & + & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & - & ,has_wetscav, rainprod2d, evapprod2d & + & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & & ,elec2,its,ids,ide,jds,jde & & ) @@ -2674,28 +3105,32 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,dz2d & & ,t0,t9 & & ,an,dn1,t77 & - & ,pn,wn & + & ,pn,wn & + & ,ngs & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) + ENDIF + + + ENDDO ! loopcnt=1,loopmax IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite ! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. ! Search for 'axtra' to find example code below ! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) - ENDDO ENDDO ENDIF ! compute diagnostic S-band reflectivity if needed - IF ( present( dbz ) .and. makediag ) THEN + IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN ! calc dbz IF ( .true. ) THEN @@ -2733,7 +3168,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & - present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. & + lastlooptmp) THEN IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN DO kz = kts,kte DO ix = its,ite @@ -2743,14 +3179,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t1(ix,1,kz) = 2.51E-6 t2(ix,1,kz) = 10.01E-6 t3(ix,1,kz) = 25.E-6 + t4(ix,1,kz) = 50.e-6 ENDDO ENDDO + call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & - & ,t1,t2,t3 & - & ,an,dn1 ) + & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 & + & ,f_t4=has_reqr_local,f_t5=has_reqg_local, f_t6=has_reqh_local & + & ,an=an,dn=dn1 ) DO kz = kts,kte DO ix = its,ite @@ -2761,19 +3200,63 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) ENDDO ENDDO + + IF ( present(has_reqr) .and. present( re_rain ) ) THEN + IF ( has_reqr /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( present(has_reqg) .and. present( re_graup ) ) THEN + IF ( has_reqg /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( present(has_reqh) .and. present( re_hail ) ) THEN + IF ( has_reqh /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF ENDIF ENDIF + IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN + DO ix = its,ite + hailmax1d(ix,1) = hail_max2d(ix,jy) + hailmaxk1(ix,1) = hail_maxk1(ix,jy) + ENDDO + + call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, & + hailmax1d,hailmaxk1,1 ) + DO ix = its,ite + hail_max2d(ix,jy) = hailmax1d(ix,1) + hail_maxk1(ix,jy) = hailmaxk1(ix,1) + ENDDO +! ENDIF + ENDIF ! transform concentrations back to mixing ratios DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF @@ -2790,15 +3273,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qv(ix,kz,jy) = an(ix,1,kz,lv) qc(ix,kz,jy) = an(ix,1,kz,lc) qr(ix,kz,jy) = an(ix,1,kz,lr) - IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li) qs(ix,kz,jy) = an(ix,1,kz,ls) qh(ix,kz,jy) = an(ix,1,kz,lh) IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN ! not used here - ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN - IF ( lccna > 1 .and. .not. present( cna ) ) THEN + ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN + IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE cn(ix,kz,jy) = an(ix,1,kz,lccn) @@ -2816,6 +3299,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ENDIF + IF ( decayufccn ) THEN + IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN + an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - & + ufbackground)*(1.0 - exp(-dtp/ufccntimeconst)) + ENDIF + ENDIF + cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf) + ENDIF + + + IF ( ipconc >= 5 ) THEN ccw(ix,kz,jy) = an(ix,1,kz,lnc) @@ -2826,6 +3324,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) ENDIF + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv + IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv + IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv + ENDIF @@ -2834,6 +3337,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw #if ( WRF_CHEM == 1 ) IF ( has_wetscav ) THEN + IF ( loopmax > 1 ) THEN + ! wrferror not supported + ENDIF IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) ENDIF @@ -2841,10 +3347,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO - + + ENDDO ! jy - IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated + + + + IF ( invertccn .and. flag_ccn ) THEN ! hack to convert unactivated ccn back to activated DO jy = jts,jte DO kz = kts,kte DO ix = its,ite @@ -2854,6 +3364,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF + IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cnuf(ix,kz,jy) = qccnuf - cnuf(ix,kz,jy) + ENDDO + ENDDO + ENDDO + ENDIF + + @@ -3042,7 +3563,6 @@ END function GAMXINFDP ! ##################################################################### -! #ifdef Z3MOM real function gaminterp(ratio, alp, luindex, ilh) implicit none @@ -3086,7 +3606,6 @@ real function gaminterp(ratio, alp, luindex, ilh) ! ENDIF END FUNCTION gaminterp -! #endif /* Z3MOM */ ! ##################################################################### !**************************** GAML02 *********************** @@ -3136,7 +3655,7 @@ END FUNCTION GAML02 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) ! ********************************************************** - real FUNCTION GAML02d300(x) + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np real x @@ -3429,7 +3948,7 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp - STOP + STOP ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) @@ -3468,7 +3987,8 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) RETURN END Function delabk - + + ! ##################################################################### ! @@ -3488,7 +4008,238 @@ end subroutine cld_cpu ! !-------------------------------------------------------------------------- ! - subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & +! ####################################################################### +! HAILMAXD - calculated maximum expected hail size +! ####################################################################### + subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & + & hailmax1d,hailmaxk1,jslab ) +! +! Calculate maximum hail size from the tail of of the distribution. The value +! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf). +! This uses the lookup tables for incomplete gamma functions and simply search for +! the expected value (and linearly interpolate) on D. +! +! Written by ERM 7/2023 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density +! integer :: its,ite ! x-range to calculate + + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters + real :: hailmax1d(nx,ny),hailmaxk1(nx,ny) + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + double precision :: tmp, ratio, del, g1palp + real, parameter :: dz = 200. + + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + real :: alp, diam, diam1, hwdn + +! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp) + DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter + real :: cwchtmp,cwchltmp, maxdia + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + integer :: ialp, i, j + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + IF ( lh > 1 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ENDIF + IF ( lhl > 1 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ENDIF + + + kzb = 1 + kze = nz + + ixb = 1 ! aliased its + ixe = nx ! aliased ite + + + jy = jslab + jgs = jy + + +! hailmax1d(:,jy) = 0.0 +! hailmaxk1(:,jy) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + +! first graupel, even if hail is also predicted, since graupel can sometime be large on its own + IF ( lh > 1 .and. lnh > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN + IF ( lvh .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = rho_qh + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,2) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + diam = (6.0*tmp/pi)**(1./3.) + IF ( lzh > 1 ) THEN ! 3moment + cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.) + ENDIF + diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh) + alp = alpha2d(ix,1,kz,2) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF ! lh + +! And diam for hail if present + IF ( lhl > 1 .and. lnhl > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = rho_qhl + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,3) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + diam = (6.0*tmp/pi)**(1./3.) + IF ( lzhl > 1 ) THEN ! 3moment + cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.) + ENDIF + diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl) + alp = alpha2d(ix,1,kz,3) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF + + + END SUBROUTINE HAILMAXD +! ####################################################################### +! ####################################################################### + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & t0,t7,infdo,jslab,its,jts, & & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing ! @@ -3517,7 +4268,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) real dtp real xfall(nx,ny,na) ! array for stuff landing on the ground - real xfall0(nx,ny) ! dummy array +! real xfall0(nx,ny) ! dummy array integer infdo integer jslab ! which line of xfall to use @@ -3525,47 +4276,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. - real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted - real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) - real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) +! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted +! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) +! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) - real :: rhovtzx(nz,nx) +! real :: rhovtzx(nz,nx) + + real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + real, allocatable :: rhovtzx(:,:) + real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:) double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy double precision :: dt1,dt2,dt3,dt4 - integer,parameter :: ngs = 128 + integer :: ngs ! = 512 integer :: ngscnt,mgs,ipconc0 - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: vx(ngs,li:lhab) - real :: alpha(ngs,lc:lhab) - real :: zx(ngs,lr:lhab) - logical :: hasmass(nx,lc+1:lhab) - - integer igs(ngs),kgs(ngs) - - real rho0(ngs),temcg(ngs) - - real temg(ngs) - - real rhovt(ngs) - - real cwnc(ngs),cinc(ngs) - real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - - real cimasn,cimasx,cnina(ngs),cimas(ngs) - - real cnostmp(ngs) +! real :: qx(ngs,lv:lhab) +! real :: qxw(ngs,ls:lhab) +! real :: cx(ngs,lc:lhab) +! real :: xv(ngs,lc:lhab) +! real :: vtxbar(ngs,lc:lhab,3) +! real :: xmas(ngs,lc:lhab) +! real :: xdn(ngs,lc:lhab) +! real :: xdia(ngs,lc:lhab,3) +! real :: vx(ngs,li:lhab) +! real :: alpha(ngs,lc:lhab) +! real :: zx(ngs,lr:lhab) +! logical :: hasmass(nx,lc+1:lhab) +! +! integer igs(ngs),kgs(ngs) +! +! real rho0(ngs),temcg(ngs) +! +! real temg(ngs) +! +! real rhovt(ngs) +! +! real cwnc(ngs),cinc(ngs) +! real fadvisc(ngs),cwdia(ngs),cipmas(ngs) +! +! real cimasn,cimasx,cnina(ngs),cimas(ngs) +! +! real cnostmp(ngs) + + real, allocatable :: qx(:,:) + real, allocatable :: qxw(:,:) + real, allocatable :: cx(:,:) + real, allocatable :: xv(:,:) + real, allocatable :: vtxbar(:,:,:) + real, allocatable :: xmas(:,:) + real, allocatable :: xdn(:,:) + real, allocatable :: xdia(:,:,:) + real, allocatable :: vx(:,:) + real, allocatable :: alpha(:,:) + real, allocatable :: zx(:,:) + logical, allocatable :: hasmass(:,:) + + integer, allocatable :: igs(:),kgs(:) + + real, allocatable :: rho0(:),temcg(:) + + real, allocatable :: temg(:) + + real, allocatable :: rhovt(:) + + real, allocatable :: cwnc(:),cinc(:) + real, allocatable :: fadvisc(:),cwdia(:),cipmas(:) + + real, allocatable :: cnina(:),cimas(:) + + real, allocatable :: cnostmp(:) + + real :: cimasn,cimasx !----------------------------------------------------------------------------- @@ -3579,7 +4364,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ################################################################### - + allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) ) + allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ) + allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)) + + ngs = nz+3 + + allocate( qx(ngs,lv:lhab), & + qxw(ngs,ls:lhab), & + cx(ngs,lc:lhab), & + xv(ngs,lc:lhab), & + vtxbar(ngs,lc:lhab,3), & + xmas(ngs,lc:lhab), & + xdn(ngs,lc:lhab), & + xdia(ngs,lc:lhab,3), & + vx(ngs,li:lhab), & + alpha(ngs,lc:lhab), & + zx(ngs,lr:lhab), & + hasmass(nx,lc+1:lhab), & + igs(ngs),kgs(ngs), & + rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), & + cwnc(ngs),cinc(ngs), & + fadvisc(ngs),cwdia(ngs),cipmas(ngs), & + cnina(ngs),cimas(ngs), & + cnostmp(ngs) ) kzb = 1 kze = nz @@ -3717,13 +4525,15 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == n*(n/interval_sedi_vt) ) ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN ! ! zero the precip flux arrays (2d) ! -! xvt(:,:,:,il) = 0.0 dummy = 0.d0 + + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & @@ -3749,7 +4559,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN - IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. & + (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) ENDIF @@ -3774,6 +4585,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF +! reflectivity + + IF ( ipconc .ge. 6 ) THEN + IF ( lz(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & an,db1,lz(il),0,xfall,dtz1,ix) + ENDIF + ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' @@ -3787,9 +4606,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! to put a lower bound on number conc. ! - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) & + & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. & & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + ! set up for method I+II DO kz = kzb,kze ! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) @@ -3802,7 +4623,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ELSE - + ! set up for method II only DO kz = kzb,kze ! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) @@ -3831,7 +4652,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & - & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) & + .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & & tmpn2,db1,1,0,xfall0,dtz1,ix) call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & @@ -3842,12 +4664,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh ) ) THEN + & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN ! "Method I" - dbz correction call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & - & lvol(il), rho_qh, infall, ix) + & lvol(il), xdn0(il), infall, ix) ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN @@ -3858,7 +4680,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ENDDO ENDDO - ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN ! "Method II" M-wgt N-fallout correction DO kz = kzb,kze @@ -3885,8 +4707,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ! ix + deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx ) + deallocate( xfall0, xvt, tmpn ) + deallocate( tmpn2, z) + + deallocate( qx, & + qxw, & + cx, & + xv, & + vtxbar, & + xmas, & + xdn, & + xdia, & + vx, & + alpha, & + zx, & + hasmass, & + igs,kgs, & + rho0,temcg,temg, rhovt, & + cwnc,cinc, & + fadvisc,cwdia,cipmas, & + cnina,cimas, & + cnostmp ) - RETURN END SUBROUTINE SEDIMENT1D @@ -4040,13 +4883,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer ix,jy,kz - real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu jy = jgs ix = ixcol - IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) & + .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN DO kz = 1,kze @@ -4096,16 +4940,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & ENDDO - ELSEIF ( l .eq. lr .and. imurain == 3) THEN + ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN - xdn = 1000. + xdn = rho_qx ! 1000. + IF ( l == ls ) ynu = snu + IF ( l == lr ) ynu = rnu DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) -! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) - z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) + z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) ! qr = a(ix,jy,kz,lr) ! nrx = a(ix,jy,kz,lnr) @@ -4319,13 +5166,17 @@ END subroutine calcnfromz1d ! ############################################################################## ! ! Subroutine to calculate number concentrations from initial state that has only mixing ratio. -! N will be in #/kg, NOT #/m^3, since sedimentation is done next. -! +! Output N will be in #/m^3 in 'an' array, since sedimentation is done next. +! Output ccw,cci etc. will be in #/kg ! ! 10.27.2015: Added hail calculation ! - subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & + & qcw,qci,qsw,qrw,qhw,qhl, & + & ccw,cci,csw,crw,chw,chl, & + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + implicit none @@ -4335,6 +5186,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) ! scalars (q, N, Z) real dn(nx,nz+1) ! air density + + real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & + ccw,cci,csw,crw,chw,chl, & + cccn,cccna,vhw,vhl,qv, spechum + logical, optional, intent(in) :: invertccn_flag + real, optional :: cwmasin integer ixe,kze real alpha @@ -4346,7 +5203,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 @@ -4359,11 +5216,24 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet - real xv,xdn + real xv,xdn,cwmasinv integer :: ndbz, nmwgt, nnwgt, nwlessthanz + double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 + logical :: invertccn_local ! ------------------------------------------------------------------ + IF ( present( invertccn_flag ) ) THEN + invertccn_local = invertccn_flag + ELSE + invertccn_local = .false. + ENDIF + + IF ( present( cwmasin ) ) THEN + cwmasinv = 1.0/cwmasin + ELSE + cwmasinv = 1.0/cwmas09 + ENDIF jy = 1 @@ -4382,18 +5252,59 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF g1s = (snu+2.0)/(snu+1.0) - + qsmax = 0 + qsmax2 = 0 + qsmax3 = 0 + qsmax4 = 0 +! IF ( .not. present( qcw ) ) THEN DO kz = 1,nz DO ix = 1,nx ! ixcol +! qv_mp = spechum/(1.0_kind_phys-spechum) +! IF ( convertdry ) THEN +! qc_mp = qc/(1.0_kind_phys-spechum) + mixconv = 1 + IF ( present( spechum ) ) THEN ! convert to "dry" mixing ratios + an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) + ELSE + mixconv = 1.0d0 + ENDIF + IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) ! assume qv is "dry" mixing ratio if passed in + IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv + IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv + IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv + IF ( present( qsw ) ) THEN + an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv +! qsmax = Max( qsmax, qsw(ix,kz) ) +! qsmax2 = Max( qsmax2, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv + IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv + IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) + IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) + IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) + IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) + IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv + IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv + IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) + IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv + dninv = 1./dn(ix,kz) +! IF ( .not. present( qcw ) ) THEN ! Cloud droplets IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN - an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)/cwmas09 )*dn(ix,kz) + an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) + + IF ( invertccn_local ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) + ELSE IF ( lccn > 1 .and. lccna < 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) @@ -4401,6 +5312,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) IF ( lccna > 1 ) THEN an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF + ENDIF ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN @@ -4449,6 +5361,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. & + an(ix,jy,kz,lnr) > cxmin ) THEN + q = an(ix,jy,kz,lr) + nrx = an(ix,jy,kz,lnr) + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF + ENDIF + ! snow IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN @@ -4511,6 +5432,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF + IF ( lzh > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. & + an(ix,jy,kz,lnh) > cxmin ) THEN + q = an(ix,jy,kz,lh) + nrx = an(ix,jy,kz,lnh) + an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv + ENDIF + ENDIF + ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN @@ -4531,7 +5461,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio - ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN @@ -4540,12 +5469,68 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF - - ENDDO ! ix - ENDDO ! kz - - RETURN - + + IF ( lzhl > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. & + an(ix,jy,kz,lnhl) > cxmin ) THEN + q = an(ix,jy,kz,lhl) + nrx = an(ix,jy,kz,lnhl) + an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv + ENDIF + ENDIF + + +! ENDIF + +! spechum = qv_mp/(1.0_kind_phys+qv_mp) +! IF ( convertdry ) THEN +! qc = qc_mp/(1.0_kind_phys+qv_mp) + mixconvqv = 1 + IF ( present( spechum ) ) THEN ! convert back to "dry+vapor" mixing ratios + !an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) + mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) + spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv + ELSE + mixconvqv = 1.0d0 + ENDIF + + IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) + IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv + IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv + IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv + IF ( present( qsw ) ) THEN + qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv +! qsmax3 = Max( qsmax3, qsw(ix,kz) ) +! qsmax4 = Max( qsmax4, an(ix,jy,kz,ls) ) + ENDIF + IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv + IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv + IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv + IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv + IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv + IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv + IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv + IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv + IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv + IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv + IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv + IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv + + + ENDDO ! ix + ENDDO ! kz +! ELSE +! write(0,*) 'calcnfromq: lv = ',lv,lc,lr,li,ls,lh,lvh,lhl,lccn,lccna +! write(0,*) 'calcnfromq: nx,ny,nz,na = ',nx,ny,nz,na +! +! ENDIF + +! IF ( present( qsw ) ) THEN +! write(0,*) 'calcnfromq: qsmax = ',qsmax,qsmax2,qsmax3,qsmax4 +! ENDIF + + RETURN + END subroutine calcnfromq ! ############################################################################## @@ -4661,6 +5646,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF ENDIF ENDIF @@ -4711,6 +5699,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzh > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF ! @@ -4734,6 +5725,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzhl > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF @@ -4750,7 +5744,9 @@ END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,t1,t2,t3 & + & ,t1,t2,t3,t4,t5,t6, f_t4, f_t5,f_t6 & + & ,qcw,qci,qsw,qrw & + & ,ccw,cci,csw,crw & & ,an,dn ) implicit none @@ -4766,18 +5762,19 @@ SUBROUTINE calc_eff_radius & ! external temporary arrays ! - real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - + real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + logical, optional :: f_t4, f_t5, f_t6 ! flags to fill t4/t5/t6 for rain/graupel/hail - real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - - + real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw - ! local real pb(-norz+ng1:nz+norz) @@ -4809,8 +5806,13 @@ SUBROUTINE calc_eff_radius & real :: alpha(ngs,lc:lhab) real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s - real :: lam_c, lam_i, lam_s + real :: lam_c, lam_i, lam_s, lam_r, lam_h, lam_hl + real :: gamr1,gamr2,gamh1,gamh2,factor_r,factor_h,factor_hl integer :: il + real :: hwdn,hldn + double precision :: numh, numhl,denomh,denomhl + + logical :: flag_t4, flag_t5, flag_t6 ! ------------------------------------------------------------------------------- @@ -4825,6 +5827,28 @@ SUBROUTINE calc_eff_radius & nzend = nz kzbeg = 1 nzbeg = 1 + + flag_t4 = .false. + flag_t5 = .false. + flag_t6 = .false. + + IF ( present(f_t4) ) THEN + IF ( present(f_t4) ) THEN + flag_t4 = f_t4 + ENDIF + ENDIF + + IF ( present(f_t5) ) THEN + IF ( present(f_t5) ) THEN + flag_t5 = f_t5 + ENDIF + ENDIF + + IF ( present(f_t6) ) THEN + IF ( present(f_t6) ) THEN + flag_t6 = f_t6 + ENDIF + ENDIF jy = 1 pb(:) = 0.0 @@ -4836,11 +5860,24 @@ SUBROUTINE calc_eff_radius & gami2 = 1. ! Gamma[1 + alphac] gams1 = Gamma_sp(2. + snu) gams2 = Gamma_sp(1. + snu) + gamr1 = Gamma_sp(2. + rnu) + gamr2 = Gamma_sp(1. + rnu) factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) + IF ( present(t4) ) THEN + IF ( imurain == 3 ) THEN + factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) + ELSE + factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) + ENDIF + ENDIF + + factor_h = ((Pi*(alphah+3.)*(alphah+1.)*(alphah+1.))/6.)**(1./3.) + factor_hl = ((Pi*(alphahl+3.)*(alphahl+1.)*(alphahl+1.))/6.)**(1./3.) + ! ! jy = 1 ! working on a 2d slab !! VERY IMPORTANT: SET jgs = jy @@ -4852,29 +5889,155 @@ SUBROUTINE calc_eff_radius & DO ix = 1,nx ! ixcol rho0(mgs) = dn(ix,jy,kz) - DO il = lc,ls + IF ( present( an ) ) THEN + DO il = lc,lhab qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) ENDDO + ELSE + qx(mgs,:) = 0.0 + cx(mgs,:) = 0.0 + IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) + IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) + IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) + IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) + IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) + IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) + IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) + IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) - IF ( qx(mgs,lc) > qxmin(lc) ) THEN + ENDIF + + IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN ! Lambda for cloud droplets lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) t1(ix,jy,kz) = 0.5*factor_c/lam_c ENDIF - IF ( qx(mgs,li) > qxmin(li) ) THEN + IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN ! Lambda for cloud ice lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) t2(ix,jy,kz) = 0.5*factor_i/lam_i ENDIF - IF ( qx(mgs,ls) > qxmin(ls) ) THEN + IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN ! Lambda for snow lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) t3(ix,jy,kz) = 0.5*factor_s/lam_s ENDIF + IF ( present( t4 ) .and.( ( present(qrw) .and. present(crw) ) .or. flag_t4 ) ) THEN + IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( imurain == 1 ) THEN ! gamma-diameter +! Lambda for rain + lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) + t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r + ELSE ! gamma-volume +! Lambda for rain + lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) + t4(ix,jy,kz) = 0.5*factor_r/lam_r + ENDIF + ENDIF + ENDIF + + IF ( present(t5) .and. flag_t5 ) THEN + + ! first: case when hail is off + + IF ( lhl < 1 .or. flag_t6 ) THEN + ! graupel only + IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) ) THEN + ! Lambda for graupel + hwdn = xdn0(lh) + IF ( lvh > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) + ENDIF + ENDIF + + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) + t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h + ENDIF + + ELSE ! have hail, too, but do not have t6 array + + IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) < Max(1.e-8,qxmin(lhl)) ) THEN +! Lambda for graupel + hwdn = xdn0(lh) + IF ( lvh > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) + ENDIF + ENDIF + + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) + t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h + + ELSEIF ( qx(mgs,lh) < Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN +! Lambda for hail + hldn = xdn0(lhl) + IF ( lvhl > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) + ENDIF + ENDIF + + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) + t5(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl + + ELSEIF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN +! r_eff graupel and hail combined + + hldn = xdn0(lhl) + IF ( lvhl > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) + ENDIF + ENDIF + + hwdn = xdn0(lh) + IF ( lvh > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) + ENDIF + ENDIF + + lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) + + numh = cx(mgs,lh)*(alphah+3.)*(alphah+2.)*(alphah+1.)/lam_h**3 + numhl = cx(mgs,lhl)*(alphahl+3.)*(alphahl+2.)*(alphahl+1.)/lam_hl**3 + + denomh = cx(mgs,lh)*(alphah+2.)*(alphah+1.)/lam_h**2 + denomhl = cx(mgs,lhl)*(alphahl+2.)*(alphahl+1.)/lam_hl**2 + + t5(ix,jy,kz) = 0.5*(numh + numhl)/(denomh + denomhl) + + + ENDIF ! no t6 array + + ENDIF ! lhl + + ENDIF ! flag_t5 + + IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN + + IF ( qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN +! Lambda for hail + hldn = xdn0(lhl) + IF ( lvhl > 1 ) THEN ! variable density + IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) + ENDIF + ENDIF + + lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) + t6(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl + + ENDIF + + ENDIF ! t6 + ENDDO ! ix ENDDO ! kz @@ -6172,7 +7335,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! DO il = lc,lhab ! IF ( il .ne. lr ) THEN DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( ildo == 0 .or. ildo == lc ) THEN + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + ENDIF IF ( li .gt. 1 ) THEN ! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) ! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) @@ -6242,6 +7407,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) + ELSEIF ( icdxhl <= 0 ) THEN ! + aax = ax(lhl) + bbx = bx(lhl) ENDIF ENDIF ! } @@ -6285,7 +7453,6 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & aax = ax(il) vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y ENDIF - ! vtxbar(mgs,il,2) = & ! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & ! & x)/y @@ -6307,7 +7474,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,il,3) = rhovt(mgs)* & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y -! & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) +! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y @@ -6549,7 +7716,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real vtmax real xvbarmax - + + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail + integer l1, l2 double precision :: dpt1, dpt2 @@ -6825,10 +7996,466 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ELSEIF ( imurain == 3 ) THEN alpha(:,lr) = xnu(lr) ENDIF + + + IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + + +! +! Set 6th moments +! + IF ( ipconc .ge. 6 .or. lzr > 1) THEN + + zx(:,:) = 0.0 + +! DO il = lr,lhab + DO il = l1,l2 + + IF ( lz(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0) + ENDDO + + + ENDIF + + ENDDO + + ENDIF + + + + +! Find shape parameter rain + + + IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + il = lr + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN +! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) +! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN +! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! tmp = cx(mgs,lr) +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) +! ENDIF + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) +! vr = xv(mgs,lr) + +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! write(91,*) 'alpha = ',alpha(mgs,il) + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) + vr = xv(mgs,lr) +! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 +! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx + + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! +! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + ENDIF + ENDIF + + ENDIF + ENDIF + + ELSE + + zx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ENDIF + + ENDDO + ENDIF ! } + + + IF ( ipconc .ge. 6 ) THEN + +! Find shape parameters for graupel,hail + + DO il = lr,lhab + + IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN +! tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) +! +! ENDIF + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? +! write(91,*) 'ziegfall: something screwy with moments: il = ',il +! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il) +! write(91,*) 'alpha = ',alpha(mgs,il) + + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! write(0,*) 'alpha = ',alpha(mgs,il) + ! set values according to dBZ of -10 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2) + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 +! write(0,*) 'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + +! check for artificial breakup (graupel/hail larger than allowed max size) + + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN + +!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ELSE + ENDIF + ENDIF + ENDDO ! mgs + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + +! CALL cld_cpu('Z-MOMENT-ZFAll') + + ENDIF + IF ( lzhl > 1 ) THEN + IF ( lhl .gt. 1 ) THEN + + ENDIF + ENDIF @@ -6860,6 +8487,19 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN +! IF ( qx(mgs,il) > 1.e-4 .and. & +! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN +! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs +! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg .or. il == lr ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) @@ -6870,6 +8510,18 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & & vtxbar(mgs,il,3) .gt. vtmax ) THEN +! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN +! write(0,*) 'infdo = ',infdo +! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) @@ -7379,6 +9031,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .le. 2 ) THEN gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( lzr .gt. 1 ) THEN + dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr) ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN IF ( imurain == 3 ) THEN vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) @@ -7571,7 +9225,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size ! p = 0.106214 for m = p v^(2/3) - dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) IF ( .true. .or. dnsnow < 900. ) THEN gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & @@ -7647,6 +9301,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzh > 1 ) THEN + IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. & + an(ix,jy,kz,lnh) >= cxmin ) ltest = .true. + ENDIF IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN @@ -7692,6 +9350,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzh .gt. 1 ) THEN + x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const + dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmph ELSE g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw @@ -7764,6 +9425,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzhl > 1 ) THEN + IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. & + an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true. + ENDIF IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ chl = an(ix,jy,kz,lnhl) @@ -7787,6 +9452,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzhl .gt. 1 ) THEN !{ + x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const + dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmphl ELSE !} g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) @@ -7895,8 +9563,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & write(0,*) 'dtmpr = ',dtmpr write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN - write(0,*) 'dbz out of bounds! STOP!' -! STOP + write(0,*) 'dbz out of bounds!' +! STOP ENDIF ENDIF @@ -7937,6 +9605,8 @@ END subroutine radardd02 ! ##################################################################### ! ! Subroutine for explicit cloud condensation and droplet nucleation +! +! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1) ! SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & @@ -7945,6 +9615,7 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,ngs & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -8003,6 +9674,7 @@ SUBROUTINE NUCOND & logical :: io_flag real :: dv + real :: ccnefactwo, sstmp, cn1, cnuctmp ! ! declarations microphysics and for gather/scatter @@ -8011,7 +9683,6 @@ SUBROUTINE NUCOND & real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs - parameter (ngs=500) integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -8030,6 +9701,7 @@ SUBROUTINE NUCOND & real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs) real ccncuf(ngs) real sscb ! 'cloud base' SS threshold parameter ( sscb = 2.0 ) @@ -8042,7 +9714,7 @@ SUBROUTINE NUCOND & integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold - real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx real dnnet,dqnet ! real cnu,rnu,snu,cinu @@ -8160,14 +9832,12 @@ SUBROUTINE NUCOND & real :: cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure integer :: kstag integer :: count - ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -8181,6 +9851,7 @@ SUBROUTINE NUCOND & kzbeg = 1 nzbeg = 1 + IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0)) f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) jy = 1 @@ -8264,7 +9935,7 @@ SUBROUTINE NUCOND & if ( temg(1) .lt. tfr ) then end if ! - if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxsupersat ) .and. & + if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & @@ -8291,6 +9962,7 @@ SUBROUTINE NUCOND & qx(:,:) = 0.0 cx(:,:) = 0.0 + zx(:,:) = 0.0 xv(:,:) = 0.0 xmas(:,:) = 0.0 @@ -8350,6 +10022,7 @@ SUBROUTINE NUCOND & ELSE ! equation set 2 in cm1 tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & @@ -8404,12 +10077,16 @@ SUBROUTINE NUCOND & ELSE ssmax(mgs) = 0.0 ENDIF - IF ( lccn .gt. 1 ) THEN - ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ENDIF ELSE ccnc(mgs) = cwnccn(mgs) ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) ELSE ccncuf(mgs) = 0.0 @@ -8464,8 +10141,239 @@ SUBROUTINE NUCOND & ventrxn(:) = ventrn +! Find shape parameter rain -! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM + DO mgs = 1,ngscnt + zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0) + ENDDO + +! CALL cld_cpu('Z-MOMENT-1r2') + il = lr + DO mgs = 1,ngscnt + + IF ( zx(mgs,il) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( cx(mgs,il) <= 0.0 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + + ENDIF +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + + ENDIF + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( imurain == 1 ) THEN + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) +! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z1 = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z1*(pi/6.*1000.)**2/xv + + +! determine shape parameter alpha by iteration + IF ( z1 .gt. 0.0 ) THEN + + IF ( imurain == 3 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + ELSE ! imurain == 1 + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2 + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF +! ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( imurain == 3 ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z1 + ENDIF + ENDIF + + ELSEIF ( imurain == 1 ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + z1 = g1*rho0(mgs)**2*(qr)*qr/nrx + z2 = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z2 + an(igs(mgs),jy,kgs(mgs),lz(il)) = z2 + ENDIF + ENDIF ! imurain + + ENDIF ! z > 0 + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + + ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/y + + + ENDIF + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r2') + ENDIF ! } + + +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 DO mgs = 1,ngscnt @@ -8483,6 +10391,8 @@ SUBROUTINE NUCOND & ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) +! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs) + ENDDO @@ -8492,7 +10402,7 @@ SUBROUTINE NUCOND & ! cloud water variables ! - if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables' do mgs = 1,ngscnt xv(mgs,lc) = 0.0 @@ -8596,7 +10506,9 @@ SUBROUTINE NUCOND & DO mgs=1,ngscnt dcloud = 0.0 - IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxsupersat ) THEN + ! Skip points at low temperature if SS stays less than 1.08, + ! otherwise allow nucleation at low temp (will freeze at next time step) + IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN CYCLE ENDIF @@ -8614,23 +10526,22 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) - thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF qx(mgs,lc) = 0. IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN - IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) - ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) - ENDIF - ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) + ENDIF ENDIF ENDIF cx(mgs,lc) = 0. @@ -8640,39 +10551,37 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) - ENDIF ENDIF cx(mgs,lc) = 0. ELSE tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) ) ELSE - ccnc(mgs) = ccnc(mgs) + tmp + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - tmp - ENDIF ENDIF cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF - thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -8954,6 +10863,19 @@ SUBROUTINE NUCOND & !! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + ENDIF + zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr ) + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*f1 ltemq = (temg(mgs)-163.15)/fqsat+1.5 @@ -8995,7 +10917,8 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK - IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test ! IF ( ssf(mgs) > ssmx ) THEN ! original condition CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) @@ -9006,7 +10929,7 @@ SUBROUTINE NUCOND & ELSE dcloud = 0.0 ENDIF - + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD @@ -9031,11 +10954,16 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + IF ( ac_opt == 0 ) THEN + cnuctmp = cnuc(mgs) + ELSE + cnuctmp = ccnc_ac(mgs) + ENDIF ! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN ! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 - CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & & .and. ncdebug .ge. 1 ) THEN write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & @@ -9057,12 +10985,16 @@ SUBROUTINE NUCOND & ENDIF IF ( cn(mgs) .gt. 0.0 ) THEN - IF ( cn(mgs) .gt. ccnc(mgs) ) THEN - cn(mgs) = ccnc(mgs) -! ccnc(mgs) = 0.0 + IF ( ac_opt == 0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF + ELSE + cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF @@ -9108,7 +11040,8 @@ SUBROUTINE NUCOND & DSSDZ=0. r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) - IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) IF ( irenuc < 2 ) THEN !{ @@ -9185,6 +11118,7 @@ SUBROUTINE NUCOND & ! nucleation CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) ) IF ( .false. .and. ny <= 2 ) THEN write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn @@ -9212,8 +11146,136 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 3 ) THEN !} { + ! Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck + +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) ! + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 4 ) THEN !} { + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp +! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs) + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air +! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + + + ELSEIF ( irenuc == 6 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + + ELSE + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + +! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + +! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) ! + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) ! +! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! cn(mgs) = 0.0 + ENDIF +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF ELSEIF ( irenuc == 5 ) THEN !} { ! modification of Phillips Donner Garner 2007 @@ -9271,17 +11333,22 @@ SUBROUTINE NUCOND & ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 7 ) THEN !} { + ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} { ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) cn(mgs) = 0.0 + IF ( irenuc == 7 ) THEN + frac = 0.9 + ELSE + frac = 0.98 + ENDIF ! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation - IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation - CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN ! prevent this branch from activating more than 70% of CCN - CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) + CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) !! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN @@ -9319,7 +11386,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) ! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN - IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) ENDIF @@ -9421,7 +11488,7 @@ SUBROUTINE NUCOND & IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ! create some small droplets at minimum size (CP 2000), although it adds very little liquid @@ -9440,8 +11507,6 @@ SUBROUTINE NUCOND & ccna(mgs) = ccna(mgs) + cn(mgs) - - ENDIF ! irenuc >= 0 .and. .not. flag_qndrop IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. @@ -9494,7 +11559,11 @@ SUBROUTINE NUCOND & ELSEIF ( imaxsupopt == 4 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) ENDIF - ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) + cn(mgs) + ELSE + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + ENDIF cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ENDIF @@ -9599,15 +11668,21 @@ SUBROUTINE NUCOND & ! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) end if + IF ( lzr > 1 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 ) + ENDIF IF ( ipconc .ge. 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) - IF ( lccn .gt. 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + IF ( ac_opt == 0 ) THEN + IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) ENDIF IF ( lccna .gt. 1 ) THEN @@ -9684,6 +11759,42 @@ SUBROUTINE NUCOND & IF ( lhl .gt. 1 ) THEN + IF ( lzhl .gt. 1 ) THEN + + an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment + + IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + hwdn = Max( xdnmn(lhl), hwdn ) + ELSE + hwdn = xdn0(lhl) + ENDIF + + chw = an(ix,jy,kz,lnhl) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl) + ENDIF + ENDIF + + ENDIF !lzhl if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then @@ -9703,6 +11814,10 @@ SUBROUTINE NUCOND & IF ( lhlw .gt. 1 ) THEN an(ix,jy,kz,lhlw) = 0.0 ENDIF + + IF ( lnhlf .gt. 1 ) THEN + an(ix,jy,kz,lnhlf) = 0.0 + ENDIF IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = 0.0 @@ -9780,13 +11895,49 @@ SUBROUTINE NUCOND & + IF ( lzh .gt. 1 ) THEN - if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then - -! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) - an(ix,jy,kz,lh) = 0.0 -! ENDIF + an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) ) + + IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN + + IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + + chw = an(ix,jy,kz,lnh) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) ) + + IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh) + ENDIF + ENDIF + + ENDIF + + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN an(ix,jy,kz,lnh) = 0.0 @@ -9799,6 +11950,10 @@ SUBROUTINE NUCOND & IF ( lhw .gt. 1 ) THEN an(ix,jy,kz,lhw) = 0.0 ENDIF + + IF ( lnhf .gt. 1 ) THEN + an(ix,jy,kz,lnhf) = 0.0 + ENDIF IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = 0.0 @@ -9936,6 +12091,9 @@ SUBROUTINE NUCOND & end if + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) ) + ENDIF if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & & ) then @@ -9946,6 +12104,10 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lnr) = 0.0 ENDIF + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = 0.0 + ENDIF + end if ! @@ -9998,18 +12160,25 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lc)= 0.0 IF ( ipconc .ge. 2 ) THEN - IF ( lccn .gt. 1 ) THEN - an(ix,jy,kz,lccn) = & - & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN + IF ( irenuc < 5 .and. lccna <= 1 ) THEN + IF ( ac_opt == 0 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + ELSEIF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) ) + ENDIF ENDIF an(ix,jy,kz,lnc) = 0.0 + IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) - IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) - - ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ENDIF + ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN ! in this case, we are treating the ccn field as ccna tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) ! IF ( ny == 2 .and. ix == nx/2 ) THEN @@ -10071,8 +12240,9 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & - & , has_wetscav,rainprod2d, evapprod2d & + & , has_wetscav,rainprod2d, evapprod2d, alpha2d & & ,elec,its,ids,ide,jds,jde & & ) @@ -10153,9 +12323,17 @@ subroutine nssl_2mom_gs & integer :: my_rank = 0 integer, parameter :: myprock = 1, nprock = 1 logical, intent(in) :: has_wetscav + integer, intent(in) :: numproc + real, intent(inout) :: thproc(nz,numproc) + real, intent(in) :: dx1,dy1 real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) + + real, parameter :: tfrdry = 243.15 + + logical lrescalelow(lc:lhab) real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) @@ -10192,7 +12370,6 @@ subroutine nssl_2mom_gs & logical, parameter :: usegamxinf3 = .false. ! real rar ! rime accretion rate as calculated from qxacw - ! a few vars for time-split fallout real vtmax integer n,ndfall @@ -10299,7 +12476,6 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs - parameter (ngs=500) !500) integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) @@ -10362,7 +12538,8 @@ subroutine nssl_2mom_gs & real ex1, ft, rhoinv(ngs) double precision ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim real dw,dwr double precision :: tmpz, tmpzmlt real ratio, delx, dely @@ -10443,7 +12620,7 @@ subroutine nssl_2mom_gs & real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real elv(ngs),elf(ngs),els(ngs) - real tsqr(ngs),ssi(ngs),ssw(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs) real qcwtmp(ngs),qtmp,qtot(ngs) real qcond(ngs) real ctmp, sctmp @@ -10458,6 +12635,7 @@ subroutine nssl_2mom_gs & parameter ( rwradmn = 50.e-6 ) real dh0 real dg0(ngs),df0(ngs) + real dhwet(ngs),dhlwet(ngs),dfwet(ngs) real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 @@ -10465,7 +12643,7 @@ subroutine nssl_2mom_gs & ! other arrays real fwet1(ngs),fwet2(ngs) - real fmlt1(ngs),fmlt2(ngs) + real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs) real fvds(ngs),fvce(ngs),fiinit(ngs) real fvent(ngs),fraci(ngs),fracl(ngs) ! @@ -10483,13 +12661,13 @@ subroutine nssl_2mom_gs & real cvm,cpm,rmm - real, parameter :: rovcp = rd/cp real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure ! real fcci(ngs), fcip(ngs) ! real :: sfm1(ngs),sfm2(ngs) real :: gfm1(ngs),gfm2(ngs) + real :: ffm1(ngs),ffm2(ngs) real :: hfm1(ngs),hfm2(ngs) logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) @@ -10519,6 +12697,7 @@ subroutine nssl_2mom_gs & real :: vtxbar(ngs,lc:lhab,3) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) + real :: xdntmp(ngs,lc:lhab) real :: cdxgs(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: vtwtdia(ngs,lr:lhab) ! sweep-out volume weighted diameter @@ -10529,6 +12708,10 @@ subroutine nssl_2mom_gs & real :: alpha(ngs,lc:lhab) real :: dab0lh(ngs,lc:lhab,lc:lhab) real :: dab1lh(ngs,lc:lhab,lc:lhab) + real :: zx(ngs,lr:lhab) + real :: zxmxd(ngs,lr:lhab) + real :: g1x(ngs,lr:lhab) + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis @@ -10544,6 +12727,7 @@ subroutine nssl_2mom_gs & real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr + real g1smlr, alphasmlr real massfacshr, massfacmlr real :: qhgt8mm ! ice mass greater than 8mm @@ -10556,6 +12740,8 @@ subroutine nssl_2mom_gs & real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + real hxventtmp + real hlventinc(ngs),hwventinc(ngs) integer, parameter :: ndiam = 10 integer :: numdiam real hwvent0(ndiam+4),hlvent0 ! 0 to d1 @@ -10643,6 +12829,7 @@ subroutine nssl_2mom_gs & real chlsbv(ngs), chldpv(ngs) real chlmlr(ngs), chlmlrr(ngs) + real chlfmlr(ngs) ! real chlmlrsave(ngs),chlsave(ngs),qhlsave(ngs) real chlshr(ngs), chlshrr(ngs) @@ -10668,15 +12855,15 @@ subroutine nssl_2mom_gs & real qrcnw(ngs), qwcnr(ngs) real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) - real qracw(ngs) ! qwacr(ngs), real qiacw(ngs) !, qwaci(ngs) real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! + real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfcev(ngs) real qfmul1(ngs),cfmul1(ngs) ! real qsacws(ngs) @@ -10685,7 +12872,7 @@ subroutine nssl_2mom_gs & ! arrays for x-ac-r and r-ac-x; ! real qsacr(ngs),qracs(ngs) - real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs) real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) real qiacr(ngs),qraci(ngs) @@ -10693,7 +12880,7 @@ subroutine nssl_2mom_gs & real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) - real :: qhlacr(ngs),qhlacrmlr(ngs) + real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs) real qsacrs(ngs) !,qracss(ngs) ! ! ice - ice interactions @@ -10739,7 +12926,8 @@ subroutine nssl_2mom_gs & real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) - real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) +! real zsmlr(ngs) + real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) real zhcns(ngs), zhcni(ngs) real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes @@ -10780,9 +12968,10 @@ subroutine nssl_2mom_gs & ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) - real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp ! real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) + real :: qffz(ngs) ! real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) @@ -10792,6 +12981,7 @@ subroutine nssl_2mom_gs & real qhshh(ngs) !accreted water that remains on graupel real qhmlh(ngs) !melt water that remains on graupel real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qffzf(ngs) !water that freezes on mixed-phase FD real qhlfzhl(ngs) !water that freezes on mixed-phase hail real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters @@ -10843,6 +13033,7 @@ subroutine nssl_2mom_gs & real qrshr(ngs) real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real ffwmax(ngs) real qhcnf(ngs) real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) @@ -10856,7 +13047,7 @@ subroutine nssl_2mom_gs & real ehxr(ngs),ehlr(ngs),egmr(ngs) real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) - real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) @@ -10915,12 +13106,13 @@ subroutine nssl_2mom_gs & real pqgli(ngs),pqghi(ngs),pqfwi(ngs) real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), - real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs) real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) + real pvhwi(ngs), pvhwd(ngs) real pvfwi(ngs), pvfwd(ngs) @@ -10932,7 +13124,7 @@ subroutine nssl_2mom_gs & real pqgld(ngs),pqghd(ngs),pqfwd(ngs) real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) real pqird(ngs),pqipd(ngs) ! pqwad(ngs), - real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs) ! ! real pqxii(ngs,nhab),pqxid(ngs,nhab) ! @@ -11036,8 +13228,8 @@ subroutine nssl_2mom_gs & real arg ! gamma is a function real erbnd1, fdgt1, costhe1 real qeps - real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii - real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr + real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii ! ,cp608 + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds real gf1palp(ngs) ! for storing Gamma[1.0 + alphar] @@ -11080,7 +13272,7 @@ subroutine nssl_2mom_gs & real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 - real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 real a1,a2,a3,a4,a5,a6 @@ -11112,9 +13304,22 @@ subroutine nssl_2mom_gs & real :: term1,term2,term3,term4 real :: qaacw ! combined qsacw-qhacw for WSM6 variation + real :: cwchtmp + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail +! inline functions for Newton method + real :: galpha, dgalpha + real :: a_in + logical, parameter :: newton = .false. + + + galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) + dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & + & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) ! ! #################################################################### ! @@ -11144,6 +13349,11 @@ subroutine nssl_2mom_gs & jstag = 0 kstag = 1 + lrescalelow(:) = rescale_low_alpha + lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha + lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha + IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha + IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha ! @@ -11200,7 +13410,7 @@ subroutine nssl_2mom_gs & ! constants ! - cp608 = 0.608 +! cp608 = 0.608 aradcw = -0.27544 bradcw = 0.26249e+06 cradcw = -1.8896e+10 @@ -11231,7 +13441,7 @@ subroutine nssl_2mom_gs & gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) gf3ds = 3.0458730354120997 ! gamma(3.0+ds) gf1ds = 0.8863557896089221 ! gamma(1.0+ds) - gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) gf53rds = 0.9027452930 ! gamma(5./3.) gf73rds = 1.190639349 ! gamma(7./3.) @@ -11261,11 +13471,18 @@ subroutine nssl_2mom_gs & vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) - snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + IF ( snowmeltdia > 0.0 ) THEN + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + ENDIF tdtol = 1.0e-05 tfrcbw = tfr - cbw tfrcbi = tfr - cbi + + IF ( mixedphase ) THEN + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF ! ! ! #ifdef COMMAS @@ -11417,35 +13634,25 @@ subroutine nssl_2mom_gs & do ix = nxmpb,itile pqs(1) = t00(ix,jy,kz) -! pqs(kz) = t00(ix,jy,kz) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) temcg(1) = temg(1) - tfr tqvcon = temg(1)-cbw - ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = (temg(1)-163.15)/fqsat + 1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(1) = pqs(1)*tabqvs(ltemq) - qis(1) = pqs(1)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN + qis(1) = pqs(1)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(1) = pqs(1)*tabqis(ltemq) + ENDIF qss(1) = qvs(1) -! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN -! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) -! ENDIF - if ( temg(1) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) - qss(1) = qis(1) - else -! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN -! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) -! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) -! ENDIF + qss(1) = qis(1) end if ! ishail = .false. @@ -11521,7 +13728,12 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ENDIF qss(mgs) = qvs(mgs) ! es(mgs) = 6.1078e2*tabqvs(ltemq) ! eis(mgs) = 6.1078e2*tabqis(ltemq) @@ -11562,78 +13774,6 @@ subroutine nssl_2mom_gs & - scx(:,:) = 0.0 -! -! set shape parameters -! - IF ( imurain == 1 ) THEN - alpha(:,lr) = alphar - ELSEIF ( imurain == 3 ) THEN - alpha(:,lr) = xnu(lr) - ENDIF - - alpha(:,li) = xnu(li) - alpha(:,lc) = xnu(lc) - - IF ( imusnow == 1 ) THEN - alpha(:,ls) = alphas - ELSEIF ( imusnow == 3 ) THEN - alpha(:,ls) = xnu(ls) - ENDIF - - DO il = lr,lhab - do mgs = 1,ngscnt - IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - - - DO ic = lc,lhab - dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) - ENDDO - ENDDO - end do - - -! DO mgs = 1,ngscnt - DO il = lr,lhab - da0lx(:,il) = da0(il) - ENDDO - da0lh(:) = da0(lh) - da0lr(:) = da0(lr) - da1lr(:) = da1(lr) - da0lc(:) = da0(lc) - da1lc(:) = da1(lc) - - - IF ( lzh < 1 .or. lzhl < 1 ) THEN - rzxhlh(:) = rzhl/rz - ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN - rzxhlh(:) = 1. - ENDIF - IF ( lzr > 1 ) THEN - rzxh(:) = 1. - rzxhl(:) = 1. - ELSE - rzxh(:) = rz - rzxhl(:) = rzhl - ENDIF - - IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN - rzxs(:) = rzs - ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN - rzxs(:) = 1. - ENDIF - ! ENDDO - - IF ( lhl .gt. 1 ) THEN - DO mgs = 1,ngscnt - da0lhl(mgs) = da0(lhl) - ENDDO - ENDIF - - ventrx(:) = ventr - ventrxn(:) = ventrn - gf1palp(:) = gamma_sp(1.0 + alphar) ! ! set concentrations @@ -11802,6 +13942,124 @@ subroutine nssl_2mom_gs & +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + zx(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + DO mgs = 1,ngscnt + zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + ENDDO + ENDIF + ENDDO + + ENDIF + + IF ( ipconc .ge. 6 ) THEN + + IF ( lz(lr) .lt. 1 ) THEN + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + + + DO mgs = 1,ngscnt + IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0) + ELSE ! imurain == 1 + zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2 + ENDIF + ENDIF + + ENDIF + ENDDO + ENDIF + + ENDIF + + + scx(:,:) = 0.0 +! +! set shape parameters +! + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha' + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab' + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + end do + ENDDO + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz' + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) ! ! set factors @@ -11840,6 +14098,7 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) @@ -11962,6 +14221,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) + xdntmp(mgs,lhl) = xdn0(lhl) IF ( lvol(lhl) .gt. 1 ) THEN IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -11973,6 +14233,7 @@ subroutine nssl_2mom_gs & xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + xdntmp(mgs,lhl) = xdn(mgs,lhl) ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value @@ -11986,33 +14247,851 @@ subroutine nssl_2mom_gs & end do + IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN - IF ( imurain == 3 ) THEN - IF ( lzr > 1 ) THEN - alphashr = 0.0 - alphamlr = -2.0/3.0 - ELSE - alphashr = xnu(lr) - alphamlr = xnu(lr) - ENDIF -! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor -! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) - massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor - massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) - ELSEIF ( imurain == 1 ) THEN - IF ( lzr > 1 ) THEN - alphashr = 4.0 - alphamlr = 4.0 - ELSE - alphashr = alphar - alphamlr = alphar - ENDIF -! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor -! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + + DO mgs = 1,ngscnt + !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh) + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. + + ! M&M-C 2010: + tmp = 4. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp + + alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN +! MY 2005: + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) +! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + + ! M&M-C 2010: + tmp = 4. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp + + alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ! alphan(mgs,lh) = alpha(mgs,lh) + + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000. + il = lh + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + + il = lhl + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + + ENDIF + ENDIF + + + + ENDDO + ENDIF + + + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + alphasmlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + alphasmlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + alphasmlr = alphasmlr0 + ELSE + alphashr = alphar + alphamlr = alphar + alphasmlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF +! Find shape parameter rain + + g1shr = 1.0 + g1mlr = 1.0 + g1smlr = 1.0 + +! CALL cld_cpu('Z-MOMENT-1') + + IF ( ipconc >= 6 ) THEN + + ! set base g1x in case rain is not 3-moment + IF ( ipconc >= 6 .and. imurain == 3 ) THEN + il = lr + DO mgs = 1,ngscnt +! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)) + ENDDO + ENDIF + + IF (lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + g1shr = (alphashr+2.0)/((alphashr+1.0)) + g1mlr = (alphamlr+2.0)/((alphamlr+1.0)) + g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0)) + ELSEIF ( imurain == 1 ) THEN +! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & +! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) + g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & + & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) +! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & +! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & + & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ & + & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr)) + ENDIF + ENDIF + + IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + + +! CALL cld_cpu('Z-MOMENT-1r') + il = lr + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN + + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN + tmp = cx(mgs,il) + IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. + IF ( alp >= rnumax - 0.01 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + +! This whole section is imurain == 3, so this branch never runs +! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN +! +! tmp = alpha(mgs,lr) + 2.5 + br/2. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrxn(mgs) = x/y + + + ENDIF + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + ENDIF ! } + + ENDIF ! ipconc >= 6 + +! Find shape parameters for graupel and hail + IF ( ipconc .ge. 6 ) THEN + + DO il = lr,lhab + + ! set base values of g1x + IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN + DO mgs = 1,ngscnt + g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + ENDDO + ENDIF + + IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSE + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + alp = Max( alphamin, Min( alphamax, alp ) ) + + IF ( newton ) THEN + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = alp + ( galpha(alp) - rdi )/dgalpha(alp) + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + ELSE + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + ENDIF + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN + tmp = cx(mgs,il) + IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest ) ) THEN +! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ENDIF + + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. +! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2 +! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2 + IF ( alp >= alphamax - 0.5 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + ENDIF + +! IF ( ny .eq. 2 ) THEN +! IF ( qr .gt. 1.e-3 ) THEN +! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000. +! ENDIF +! ENDIF + + + ENDIF ! .true. + + IF ( il == lr ) THEN + +! tmp = alpha(mgs,lr) + 4./3. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +! tmp = alpha(mgs,lr) + 1. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y + + IF ( iferwisventr == 2 ) THEN + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + + ventrxn(mgs) = x/y + + ENDIF + + ENDIF ! il==lr + + + ELSE ! below mass threshold +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) +! z1 = g1*rho0(mgs)**2*(qr)*qr/chw +! z = 1.e18*z1*(6./(pi*1000.))**2 +! z = z1*(6./(pi*1000.))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF ! ( qx(mgs,il) .gt. qxmin(il) ) + + + +! ENDIF + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + +! IF ( il == lr ) THEN +! xnutmp = (alpha(mgs,il) - 2.)/3. +! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) +! ENDIF + + IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN +! CALL cld_cpu('Z-DELABK') + DO mgs = 1,ngscnt + IF ( qx(mgs,il) > qxmin(il) ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + +! IF ( .true. ) THEN + DO ic = lc,lh-1 ! lhab + IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN + xnuc = xnu(ic) + IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu + IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + xnuc = alpha(mgs,lr) ! alpha is nu already + ELSE + xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu + ENDIF + ENDIF + ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected + IF ( .false. ) THEN + dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic) + dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic) + dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) + dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + +! tmp1 = dab0lu(j,i,ic,il) +! tmp2 = dab1lu(j,i,ic,il) +! tmp3 = dab0lu(i,j,il,ic) +! tmp4 = dab1lu(i,j,il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) + write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic) + write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j + write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1 + write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2 + write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5 + write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6 + + ENDIF + + ENDIF + + ENDIF + ENDDO + +! ENDIF + + da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( il .eq. lh ) THEN + da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxh(mgs) = 1. + ELSE + rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + + IF ( lzhl < 1 ) THEN + rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))) + ENDIF + ELSEIF ( il .eq. lhl ) THEN + da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxhl(mgs) = 1. + ELSE + rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + ELSEIF ( il == lr ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1) + ENDIF + + ENDIF ! ( qx(mgs,il) > qxmin(il) ) + ENDDO ! mgs +! CALL cld_cpu('Z-DELABK') + ENDIF ! il /= lr + +! CALL cld_cpu('Z-DELABK') + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + + ENDIF ! ipconc .ge. 6 + +! CALL cld_cpu('Z-MOMENT-1') ! ! set some values for ice nucleation @@ -12044,7 +15123,7 @@ subroutine nssl_2mom_gs & ! & itype1a,itype2a,temcg,infdo,alpha) - infdo = 0 + infdo = 1 IF ( rimdenvwgt > 0 ) infdo = 1 call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & @@ -12058,9 +15137,9 @@ subroutine nssl_2mom_gs & IF ( lwsm6 .and. ipconc == 0 ) THEN tmp = Max(qxmin(lh), qxmin(ls)) DO mgs = 1,ngscnt - sum = qx(mgs,lh) + qx(mgs,ls) - IF ( sum > tmp ) THEN - vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + total = qx(mgs,lh) + qx(mgs,ls) + IF ( total > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total ELSE vt2ave(mgs) = 0.0 ENDIF @@ -12206,6 +15285,17 @@ subroutine nssl_2mom_gs & + IF ( ipconc >= 6 ) THEN + frac = 0.4d0 + zxmxd(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) > 0 .or. ( il == lr ) ) THEN + DO mgs = 1,ngscnt + zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv + ENDDO + ENDIF + ENDDO + ENDIF @@ -12243,10 +15333,10 @@ subroutine nssl_2mom_gs & vshdgs(mgs,il) = vshd ! base value - IF ( qx(mgs,il) > qxmin(il) ) THEN + IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. - tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 IF ( tmpdiam > sheddiam0 ) THEN vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice @@ -12303,13 +15393,13 @@ subroutine nssl_2mom_gs & ers(mgs) = 0.0 ess(mgs) = 0.0 ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehsfac(mgs) = 1.0 ! factor based on ice saturation ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn ehscnv(mgs) = 0.0 ! ehxs(mgs) = 0.0 ! eiw(mgs) = 0.0 eii(mgs) = 0.0 - ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 @@ -12404,7 +15494,7 @@ subroutine nssl_2mom_gs & if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then - if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then + if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then eiw(mgs) = 0.5 @@ -12528,7 +15618,7 @@ subroutine nssl_2mom_gs & ELSE fac = Abs(ess0) - IF ( .true. .and. ess0 < 0.0 ) THEN + IF ( iessopt == 2 ) THEN ! experimental code ! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN IF ( wvel(mgs) > 2.0 ) THEN ! assume convective cell or downdraft @@ -12536,9 +15626,25 @@ subroutine nssl_2mom_gs & ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values fac = Max(0.0, 2.0 - wvel(mgs))*fac ENDIF + ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.0 + ehsfac(mgs) = 0.0 + ELSEIF ( ssi(mgs) <= 1.02 ) THEN + fac = fac*(ssi(mgs) - 1.0)/0.02 + ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02 + ENDIF + ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.) + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.1 + ehsfac(mgs) = 0.1 + ELSEIF ( ssi(mgs) <= 1.005 ) THEN + fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) + ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005) + ENDIF ENDIF - IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1 ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) @@ -12649,7 +15755,11 @@ subroutine nssl_2mom_gs & ELSE ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) ENDIF - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + + IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN +! ehsclsn(mgs) = ehs_collsn +! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) +! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then ehsclsn(mgs) = ehs_collsn IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN ehsclsn(mgs) = 0.0 @@ -12659,9 +15769,9 @@ subroutine nssl_2mom_gs & ehsclsn(mgs) = ehs_collsn ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density - ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band +! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density ehs(mgs) = Min(ehs(mgs),ehsmax) - IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 end if ENDIF ! @@ -12669,7 +15779,7 @@ subroutine nssl_2mom_gs & ehiclsn(mgs) = ehi_collsn ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 end if IF ( lis > 1 ) THEN @@ -12677,7 +15787,7 @@ subroutine nssl_2mom_gs & ehisclsn(mgs) = ehi_collsn ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 end if ENDIF @@ -12814,6 +15924,7 @@ subroutine nssl_2mom_gs & end do + ! ! ! @@ -12887,6 +15998,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qraci(mgs) = 0.0 craci(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN IF ( ipconc .ge. 3 ) THEN @@ -12932,8 +16044,9 @@ subroutine nssl_2mom_gs & ENDIF end do ! + IF ( ipconc < 3 ) THEN do mgs = 1,ngscnt - qracs(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) @@ -12950,6 +16063,7 @@ subroutine nssl_2mom_gs & & , qsmxd(mgs)) ENDIF end do + ENDIF ! ! @@ -13096,6 +16210,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qhacw(mgs) = 0.0 + qhacwmlr(mgs) = 0.0 rarx(mgs,lh) = 0.0 vhacw(mgs) = 0.0 vhsoak(mgs) = 0.0 @@ -13162,6 +16277,11 @@ subroutine nssl_2mom_gs & ENDIF + qhacwmlr(mgs) = qhacw(mgs) + IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN + qhacw(mgs) = 0.0 + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail IF ( temg(mgs) .lt. 273.15) THEN @@ -13191,14 +16311,18 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & & /(temg(mgs)-273.15)) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -13412,6 +16536,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qhlacw(mgs) = 0.0 + qhlacwmlr(mgs) = 0.0 vhlacw(mgs) = 0.0 vhlsoak(mgs) = 0.0 IF ( lhl > 1 .and. .true.) THEN @@ -13440,10 +16565,15 @@ subroutine nssl_2mom_gs & qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + qhlacwmlr(mgs) = qhlacw(mgs) + IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN + qhlacw(mgs) = 0.0 + ENDIF + IF ( lvol(lhl) .gt. 1 ) THEN IF ( temg(mgs) .lt. 273.15) THEN - IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985) rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & & /(temg(mgs)-273.15))**(rimc2) @@ -13457,13 +16587,17 @@ subroutine nssl_2mom_gs & rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & & /(temg(mgs)-273.15) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -13778,7 +16912,7 @@ subroutine nssl_2mom_gs & frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) - ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs) ENDIF ENDIF @@ -13808,7 +16942,7 @@ subroutine nssl_2mom_gs & tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass IF ( tmp .lt. essfrac1 ) THEN ec0(mgs) = 1.0 - ELSEIF ( tmp .gt. essfrac2 ) THEN + ELSEIF ( tmp .ge. essfrac2 ) THEN ec0(mgs) = 0.0 ELSE ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) @@ -13885,7 +17019,21 @@ subroutine nssl_2mom_gs & ec0(mgs) = 2.e9 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) - IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + + + ! check median volume diameter + IF ( icracrthresh > 1 ) THEN + IF ( imurain == 1 ) THEN + tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM) + ELSE ! imurain == 3, + tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb) + ENDIF + ELSE + tmp = xdia(mgs,lr,3) - 0.1e-3 + ENDIF + +! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 ELSE @@ -13967,6 +17115,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' chaci(:) = 0.0 + chaci0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN @@ -14017,6 +17166,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' chacs(:) = 0.0 + chacs0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehs(mgs) .gt. 0 ) THEN @@ -14176,7 +17326,7 @@ subroutine nssl_2mom_gs & ! Ziegler (1985) autoconversion ! ! - IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + IF ( ipconc .ge. 2 ) THEN if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt @@ -14196,7 +17346,7 @@ subroutine nssl_2mom_gs & cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) cautn(mgs) = Max( 0.0d0, cautn(mgs) ) - IF ( rb(mgs) .le. 7.51d-6 ) THEN + IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN t2s = 1.d30 ! cautn(mgs) = 0.0 ELSE @@ -14259,6 +17409,47 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + IF ( ipconc >= 6 ) THEN + IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN +! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs)) +! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2) + ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1) + ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2) + ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok. + IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN + tmp3 = qx(mgs,lr)/cx(mgs,lr) + tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + if (imurain == 3) then + vr = rho0(mgs)*qrcnw(mgs)/(1000.) + tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + else + tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + endif + IF ( dmrauto == 1 ) THEN ! Preserve alpha + zrcnw(mgs) = tmp4 + ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average + zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ENDIF + else ! original formulation + IF ( imurain == 3 ) THEN + vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator + zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ELSE ! rain in gamma of diameter + IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN + zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + ELSE + tmp3 = qx(mgs,lr)/cx(mgs,lr) + zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + ENDIF +! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator +! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ENDIF + endif +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + ENDIF + ENDIF ! ipconc >= 6 ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN ! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), @@ -14469,6 +17660,15 @@ subroutine nssl_2mom_gs & ELSE !{ + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + ENDIF IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN @@ -14478,6 +17678,10 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! @@ -14489,6 +17693,10 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 + IF (ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSE !{ ! recalculate using dhmn for ratio @@ -14528,10 +17736,23 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs) + zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs) + ENDIF ENDIF ! } ELSE crfrzs(mgs) = 0.0 qrfrzs(mgs) = 0.0 + zrfrzs(mgs) = 0.0 ENDIF ! } ENDIF !} @@ -14544,6 +17765,10 @@ subroutine nssl_2mom_gs & crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + zrfrz(mgs) = fac*zrfrz(mgs) + zrfrzf(mgs) = fac*zrfrzf(mgs) + ENDIF ENDIF ENDIF !} @@ -15088,8 +18313,16 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) - IF ( lzr > 1 ) THEN ! 3 moment -! + IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment + tmp = 1. + alpr ! alpha(mgs,lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions ELSE y = ventrxn(mgs) ENDIF @@ -15105,6 +18338,13 @@ subroutine nssl_2mom_gs & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + rwventz(mgs) = 0.0 + +! rwventz(mgs) = & +! & 0.78*x + & +! & 0.308*fvent(mgs)*y* & +! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + ELSEIF ( iferwisventr == 2 ) THEN @@ -15117,6 +18357,23 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + IF ( ipconc >= 7 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) + + tmp = alpr + 5.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! rwventz(mgs) = & +! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + & + rwventz(mgs) = & + & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + & + & 0.308*fvent(mgs)* & + & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0)) + + ENDIF + ENDIF ! iferwisventr @@ -15159,6 +18416,9 @@ subroutine nssl_2mom_gs & hwventa = (0.78)*gmoi(igmhwa) hwventb = (0.308)*gmoi(igmhwb) ! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + hwvent(:) = 0.0 + hwventy(:) = 0.0 + do mgs = 1,ngscnt IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) @@ -15279,6 +18539,8 @@ subroutine nssl_2mom_gs & & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & & / (felf(mgs)) fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + fmlt1e(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs)) end do ! ! Vapor Deposition constants @@ -15306,6 +18568,7 @@ subroutine nssl_2mom_gs & qhlmlrlg(:) = 0.0 ENDIF qhfzh(:) = 0.0 + qffzf(:) = 0.0 qhlfzhl(:) = 0.0 qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 @@ -15313,9 +18576,10 @@ subroutine nssl_2mom_gs & vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 - zsmlr(:) = 0.0 +! zsmlr(:) = 0.0 zhmlr(:) = 0.0 zhmlrr(:) = 0.0 + zsmlrr(:) = 0.0 zhshr(:) = 0.0 zhlmlr(:) = 0.0 zhlshr(:) = 0.0 @@ -15329,6 +18593,7 @@ subroutine nssl_2mom_gs & chmlr(:) = 0.0 chmlrr(:) = 0.0 chlmlr(:) = 0.0 + chlfmlr(:) = 0.0 ! chlmlrsave(:) = 0.0 ! qhlmlrsave(:) = 0.0 ! chlsave(:) = 0.0 @@ -15366,7 +18631,7 @@ subroutine nssl_2mom_gs & qhmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & - & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results @@ -15397,13 +18662,13 @@ subroutine nssl_2mom_gs & qhlmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & - & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef Z3MOM -! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) +! #ifdef 1 +! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results @@ -15434,7 +18699,7 @@ subroutine nssl_2mom_gs & chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) ENDIF ! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion - qhmlh(mgs) = 0. + qhmlh(mgs) = 0. ! not used ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding @@ -15511,8 +18776,15 @@ subroutine nssl_2mom_gs & ! ENDIF - IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = alpha(mgs,lh) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + + ENDIF IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN @@ -15618,6 +18890,17 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN + IF ( cx(mgs,lhl) > 0.0 ) THEN + + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = alpha(mgs,lhl) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) + ENDIF + ENDIF ENDIF ! } ENDIF ! }.not. mixedphase @@ -15655,6 +18938,7 @@ subroutine nssl_2mom_gs & ENDDO ! ! + qhdsv(:) = 0.0 qhldsv(:) = 0.0 do mgs = 1,ngscnt @@ -15664,6 +18948,7 @@ subroutine nssl_2mom_gs & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac + ! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) ! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN ! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), @@ -15900,20 +19185,41 @@ subroutine nssl_2mom_gs & ! end of qlimit + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + qfcev(:) = 0.0 + do mgs = 1,ngscnt qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 qidpv(mgs) = 0.0 qsdpv(mgs) = 0.0 + qhsbv(mgs) = 0.0 + qscev(mgs) = 0.0 + cscev(mgs) = 0.0 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lh) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN + ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - qhdpv(mgs) = Max(qhdsv(mgs), 0.0) + ENDIF + + IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) +! qhcev(mgs) = & +! & evapfac*min( & +! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 ) + + qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs)) + IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) ) + + ENDIF + ENDIF qhlsbv(mgs) = 0.0 qhldpv(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) + qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs)) + IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) ) + + ENDIF + ENDIF ENDIF temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) @@ -16068,6 +19407,10 @@ subroutine nssl_2mom_gs & end if end do + + + + ! ! ! compute dry growth rate of snow, graupel, and hail @@ -16094,7 +19437,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - IF ( temg(mgs) < tfr ) THEN + IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN ! ! qswet(mgs) = ! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) @@ -16105,31 +19448,39 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE + IF ( incwet == 0 ) THEN qhwet(mgs) = & & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) qhwet(mgs) = max( 0.0, qhwet(mgs)) + ELSE + ENDIF + ! ENDIF qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - qhlwet(mgs) = & - & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & - & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) - qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + IF ( incwet == 0 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + + ELSE + ENDIF ! incwet ENDIF ELSE qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) - ENDIF ! ! qhlwet(mgs) = qhldry(mgs) end do + ! ! shedding rate ! @@ -16189,7 +19540,7 @@ subroutine nssl_2mom_gs & qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) ELSE ! new and correct - + ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) @@ -16280,6 +19631,8 @@ subroutine nssl_2mom_gs & IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN ! rescale volumes to maximum density + IF ( iwetsoak ) THEN + rimdn(mgs,lh) = xdnmx(lh) raindn(mgs,lh) = xdnmx(lh) vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) @@ -16293,7 +19646,10 @@ subroutine nssl_2mom_gs & v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion vhsoak(mgs) = Min(v1,v2) + + ENDIF + ENDIF vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) @@ -16349,6 +19705,8 @@ subroutine nssl_2mom_gs & IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN ! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + IF ( iwetsoak ) THEN + rimdn(mgs,lhl) = xdnmx(lhl) raindn(mgs,lhl) = xdnmx(lhl) vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) @@ -16372,6 +19730,8 @@ subroutine nssl_2mom_gs & ! vhlacw(mgs) = 0.0 ! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) @@ -16516,7 +19876,93 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF - dg0(mgs) = -1. + IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN + dg0(mgs) = -1. + ELSE + IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & + .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + sqrtrhovt = Sqrt( rhovt(mgs) ) + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + ltemq = (tfr-163.15)/fqsat+1.5 + qvs0 = pqs(mgs)*tabqvs(ltemq) + denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) + denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs)) + +! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + h4 = ehr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lh)*d**bxx(mgs,lh) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option + x1 = fventm*sqrtrhovt*Sqrt(d*vth) + IF ( x1 > 1.4 ) THEN + am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8) + ELSE + am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ & + (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp)) + + ELSE + + ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0 + ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc. + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + ENDIF + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + ELSE + IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN + dg0(mgs) = dwmax + ELSE + dg0(mgs) = dg0thresh + 0.0001 + ENDIF + ENDIF + + IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .and. temg(mgs) .le. tfr-2.0 ) THEN + ! set a secondary condition on to capture large graupel that is riming but not in wet growth + dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + ENDIF + + ENDIF wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) @@ -16551,18 +19997,6 @@ subroutine nssl_2mom_gs & tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) ! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) -! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN -! hdia1 = Max(dh0, xdia(mgs,lh,3) ) -! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & -! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & -! & *exp(-hdia1/xdia(mgs,lh,1)) & -! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & -! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) - -! ENDIF - -! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) -! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN !{ @@ -16572,8 +20006,6 @@ subroutine nssl_2mom_gs & chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter -! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) -! chlcnh(mgs) = Min( chlcnh(mgs), r ) chlcnh(mgs) = Max( chlcnhhl(mgs), r ) ENDIF !} @@ -16588,12 +20020,119 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ + IF ( wtest .and. & + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + ! convert number, mass, and reflectivity for d > dw + IF ( ipconc == 5 ) THEN + ! dg0(mgs) = Min( dg0(mgs), hldia1 ) + !dg0(mgs) = hldia1 + ENDIF + + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) + + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + IF ( ipconc == 5 ) THEN + ! tmp2 = Min( 0.25, tmp2 ) + ENDIF + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + flim = 1.0 + tmp3 = qxmxd(mgs,lh) + IF (qxd1 > tmp3 ) THEN +! flim = tmp3/(qxd1) +! qhlcnh(mgs) = flim*qhlcnh(mgs) + ENDIF + + + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF + cxd1 = flim*cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN + tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( tmp < xmas(mgs,lhl) ) THEN + ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average + dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) + ELSE +! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size + ENDIF + ENDIF + + + ! reflectivity + IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = flim*zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + + ELSE + qhlcnh(mgs) = 0.0 + ENDIF + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDIF !} ENDDO ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion +! +! Staka and Mansell (2005) type conversion +! +! hldia1 is set in micro_module and namelist +! IF ( .true. ) THEN + + ! convert number, mass, and reflectivity for d > hldia1, + ! regardless of wet growth status, but as long as riming > 0 + DO mgs = 1,ngscnt + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + + ! reflectivity + IF ( lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDDO +! ENDIF ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt @@ -16829,6 +20368,10 @@ subroutine nssl_2mom_gs & ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) +! IF ( lzh .gt. 1 ) THEN +! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & +! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) +! ENDIF vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) @@ -16868,7 +20411,13 @@ subroutine nssl_2mom_gs & IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN ! qrcev(mgs) = -qrmxd(mgs) ! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) - crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + IF ( icrcev == 1 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSEIF ( icrcev == 2 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1) + ELSE + crcev(mgs) = 0.0 + ENDIF ELSE crcev(mgs) = 0.0 ENDIF @@ -16880,12 +20429,6 @@ subroutine nssl_2mom_gs & ! ! evaporation/condensation of wet graupel and snow ! - qscev(:) = 0.0 - cscev(:) = 0.0 - qhcev(:) = 0.0 - chcev(:) = 0.0 - qhlcev(:) = 0.0 - chlcev(:) = 0.0 IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 @@ -16895,6 +20438,7 @@ subroutine nssl_2mom_gs & chlcevlg(:) = 0.0 ENDIF + ! ! ! @@ -17711,9 +21255,11 @@ subroutine nssl_2mom_gs & & + chsbv(mgs) & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) + end do + ! ! @@ -17840,6 +21386,14 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + IF ( ipconc > 5 ) THEN + pzhwi(:) = 0.0 + pzhwd(:) = 0.0 + pzrwi(:) = 0.0 + pzrwd(:) = 0.0 + pzhli(:) = 0.0 + pzhld(:) = 0.0 + ENDIF ! @@ -18078,7 +21632,8 @@ subroutine nssl_2mom_gs & qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) -! qhcev(mgs) = frac*qhcev(mgs) + qhcev(mgs) = frac*qhcev(mgs) + qhlcev(mgs) = frac*qhlcev(mgs) IF ( warmonly < 0.5 ) THEN @@ -18124,6 +21679,8 @@ subroutine nssl_2mom_gs & ! STOP ENDIF + + end do IF ( warmonly < 0.5 ) THEN @@ -18152,7 +21709,7 @@ subroutine nssl_2mom_gs & & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included ! > +il5(mgs)*(qssbv(mgs)) & - & + (qssbv(mgs)) & + & + qssbv(mgs) & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) @@ -18267,53 +21824,634 @@ subroutine nssl_2mom_gs & & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included end do -! -! Hail -! - IF ( lhl .gt. 1 ) THEN +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Graupel reflectivity +! + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity' + + do mgs = 1,ngscnt + +! zhmlr(mgs) = 0.0 +! zhshr(mgs) = 0.0 +! zhmlrr(mgs) = 0.0 +! zhshrr(mgs) = 0.0 + zhdsv(mgs) = 0.0 +! IF ( lf < 1 ) THEN + IF ( ffrzh > 0.0 ) THEN + ziacr(mgs) = 0.0 + ziacrf(mgs) = 0.0 + ENDIF +! ENDIF + zhcns(mgs) = 0.0 + zhcni(mgs) = 0.0 + zhacs(mgs) = 0.0 + zhaci(mgs) = 0.0 + + ENDDO + + IF ( lzh .gt. 1 ) THEN ! + do mgs = 1,ngscnt + + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = Max( alphamin, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) ) + zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) ) + + IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + ENDIF + + zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + +! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN + IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN +! IF ( temg(mgs) > tfr + 2.0 ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) +! IF ( zhshrr(mgs) > 0. ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) +! ENDIF +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) +! ELSE +! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + + + IF ( temg(mgs) >= tfr ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) + ! IF ( zhshrr(mgs) > 0.0 ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? + ENDIF + zhshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) + ELSE + zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ENDIF + + zhshrr(mgs) = Min( 0.0, zhshrr(mgs) ) + ENDIF + + IF ( zhshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh) + write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + + STOP + ENDIF + + +! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) + + qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs) + ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs) + + zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhacr(mgs) .gt. 0.0 ) THEN +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) +! zhacrf(mgs) = g1*zhacr + + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh)) + + IF ( z > zx(mgs,lh) ) THEN +! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv + ELSE +! zhacr(mgs) = 0.0 + ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( qhacw(mgs) .gt. 0.0 ) THEN +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) + IF ( z > zx(mgs,lh) ) THEN +! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ELSE ! } { ! this is not used because of the 'true' above + + IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + IF ( z > zx(mgs,lh) ) THEN + zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN + zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) + ENDIF + ENDIF +! qsplinter(mgs) + IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + ! note that 3.6476 = (6/pi)**2 + ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ELSE ! imurain == 1 + ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ENDIF + ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) ) +! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs) + ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) ) +! ziacrf(mgs) = Min( ziacrf(mgs), z ) + ENDIF + + + + IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) + ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN +! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & +! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) ) + zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & + & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) ) + zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + ENDIF + zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv ) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) ) +! zrfrzf(mgs) = Min( zrfrzf(mgs), z ) + ! change this to be alpha=0? + ENDIF + + IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) + + ENDIF + + IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN + tmp = qx(mgs,ls)/cx(mgs,ls) + r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles + IF ( imusnow == 3 ) THEN + zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * & + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) ) + ELSE + write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow + STOP + ENDIF + ENDIF + + IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + tmp = qx(mgs,li)/cx(mgs,li) + r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles + zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) ) + ENDIF + + + pzhwi(mgs) = & + & +ifrzg*ffrzh*(zrfrzf(mgs) & + & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & +! : + zhcnsh(mgs) + zhcnih(mgs) & + & + zhacw(mgs) & + & + zhacr(mgs) & + & + zhcnhl(mgs) & + & + zhacs(mgs) & + & + zhaci(mgs) & + & + f2h*zhcni(mgs) + f2h*zhcns(mgs) & + & + Max( 0.0, zhdsv(mgs) ) + + pzhwd(mgs) = 0.0 & + & + (1-il5(mgs))*zhmlr(mgs) & + & + zhshr(mgs) & + & + Min( 0.0, zhdsv(mgs) ) & + & - il5(mgs)*zhlcnh(mgs) + + + IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN +! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real +! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh) +! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh) +! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh) + ENDIF + + +! IF ( zhcnhl(mgs) < 0.0 ) THEN +! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) +! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp +! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) +! +!! STOP +! ENDIF + end do + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity' + + ENDIF + +! +! Hail reflectivity +! + + do mgs = 1,ngscnt + + zhldsv(mgs) = 0.0 + zhlacr(mgs) = 0.0 + zhlacw(mgs) = 0.0 + + ENDDO + + IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity' + + do mgs = 1,ngscnt + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = Max( alphamin, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) + ENDIF + + zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN + IF ( temg(mgs) >= tfr ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) ) + ! IF ( zhlshrr(mgs) > 0.0 ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? + ENDIF + zhlshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? +! zhlshrr(mgs) = Max( z1, zhlshrr(mgs)) + ELSE + zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ENDIF + + zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) ) + ENDIF + + IF ( zhlshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl) + write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + STOP + ENDIF +! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) ) + +! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) ) + + qtmp = qhldpv(mgs) + qhlcev(mgs) + ctmp = chldpv(mgs) + chlcev(mgs) + + zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhlacr(mgs) .gt. 0.0 ) THEN +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl)) + zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) +! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv +! ELSE +! zhlacr(mgs) = 0.0 +! ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + + IF ( qhlacw(mgs) .gt. 0.0 ) THEN + alp = Max( 3.0, alpha(mgs,lhl)+1. ) + g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv +! ENDIF + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + ENDIF + + ELSE ! } .false. { + + IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + IF ( z > zx(mgs,lhl) ) THEN + zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + ENDIF +! qsplinter(mgs) + + IF ( lzhl > 1 ) THEN + pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) & + & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) & + & + il5(mgs)*zhlcnh(mgs) & + & + zhlacw(mgs) & + & + zhlacr(mgs) & +! : + zhlacs(mgs) & + & + Max( 0.0, zhldsv(mgs) ) + + pzhld(mgs) = 0.0 & + & + (1-il5(mgs))*zhlmlr(mgs) & + & + zhlshr(mgs) & + & - zhcnhl(mgs) & + & + Min( 0.0, zhldsv(mgs) ) + + + IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN + write(iunit,*) 'Problem with pzhli!' + write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs) + ENDIF + + IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN + write(iunit,*) 'Problem with pzhld!' + write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs) + ENDIF + + ENDIF ! lzhl > 1 + + end do + + ENDIF + +! +! rain reflectivity +! + if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11' + + IF ( lzr .gt. 1 ) THEN ! + + DO mgs = 1,ngscnt + + zracw(mgs) = 0.0 + zracr(mgs) = 0.0 + zrcev(mgs) = 0.0 + zrach(mgs) = 0.0 + zrachl(mgs) = 0.0 + zsshr(mgs) = 0.0 + zsshrr(mgs) = 0.0 +! zsmlr(mgs) = 0.0 + zsmlrr(mgs) = 0.0 + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. & + csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{ + tmp = qx(mgs,ls)/cx(mgs,ls) + g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2) + IF ( .not. mixedphase ) THEN +! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) ) + + IF ( csmlrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) ) + zsmlrr(mgs) = z1 + ENDIF + ENDIF + +! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) ) + + IF ( csshrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) ) + zsshrr(mgs) = z1 + ENDIF + + ENDIF !} + + IF ( .not. mixedphase ) THEN !{ + IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{ + tmp = qx(mgs,lh)/cx(mgs,lh) +! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) ) + +! IF ( zhmlrr(mgs) >= 0. ) THEN +! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs) +! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel + z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ENDIF + zhmlrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) +! zhmlrr(mgs) = Max( z1, zhmlrr(mgs)) + ENDIF !} + + +! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs) + + IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) +! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) ) + +! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation +! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs) +! ENDIF + + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ENDIF + zhlmlrr(mgs) = z1 + +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs)) +! zhlmlr(mgs) = +! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs) + ENDIF + + ENDIF ! } + + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN + + tmp = qx(mgs,lr)/cx(mgs,lr) + g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + + IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) + ENDIF + + IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ENDIF + + qtmp = qrcev(mgs) + ctmp = crcev(mgs) + +! IF ( .false. .or. iferwisventr == 2 ) THEN +! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) ) +! ELSE + zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + + IF ( iferwisventr == 2 ) THEN + vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs)) + zrcev(mgs) = Max( zrcev(mgs), vent1 ) + ENDIF +! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN +! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr) +! ENDIF + + +! ENDIF + zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) ) + + IF ( qhacr(mgs) > 0.0 ) THEN + zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) ) + + ENDIF + + IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN + zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) ) + zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) ) + ENDIF - do mgs = 1,ngscnt - pqhli(mgs) = & - & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & - & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & - & +qhlacr(mgs)+qhlacw(mgs) & -! & +qhlacs(mgs)+qhlaci(mgs) & - & + qhlcnh(mgs) - pqhld(mgs) = & - & qhlshr(mgs) & - & +(1-il5(mgs))*qhlmlr(mgs) & -! > +il5(mgs)*qhlsbv(mgs) & - & + qhlsbv(mgs) & - & -qhlmul1(mgs) - qhcnhl(mgs) - end do + + ENDIF - ENDIF ! lhl + pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & + & + Max( 0.,zrcev(mgs) ) & + & - (1-il5(mgs))*zsmlrr(mgs) & + & - zsshrr(mgs) & + & - (1-il5(mgs))*zhmlrr(mgs) & + & - zhshrr(mgs) & + & - (1-il5(mgs))*zhlmlrr(mgs) & + & - zhlshrr(mgs) - ENDIF ! warmonly -! -! Liquid water on snow and graupel -! + pzrwd(mgs) = 0.0 & + & + Min(0.,zrcev(mgs) ) & + & - zrach(mgs) & + & - zrachl(mgs) & + & - zrfrz(mgs) & + & - il5(mgs)*(ziacr(mgs) ) - vhmlr(:) = 0.0 - vhlmlr(:) = 0.0 - vhfzh(:) = 0.0 - vhlfzhl(:) = 0.0 - IF ( mixedphase ) THEN - ELSE ! set arrays for non-mixedphase graupel - -! vhshdr(:) = 0.0 - vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation -! vhsoak(:) = 0.0 + IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 & + .and. qx(mgs,lr) > qxmin(lr) ) THEN + pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs) + ENDIF -! vhlshdr(:) = 0.0 - vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation -! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) -! vhlsoak(:) = 0.0 + ENDDO - ENDIF ! mixedphase + ENDIF @@ -18390,6 +22528,33 @@ subroutine nssl_2mom_gs & ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & + & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lh) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lh) + ENDIF + ELSE + dnmx = xdnmx(lh) + ENDIF + + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) ) + + drhodt = (xdn_new - xdn(mgs,lh))*dtpinv + + zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt + + pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs)) + pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs)) + + + ENDIF IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN write(iunit,*) @@ -18472,6 +22637,32 @@ subroutine nssl_2mom_gs & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & + & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lhl) + ENDIF + ELSE + dnmx = xdnmx(lhl) + ENDIF + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) ) + + drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv + + zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt + + pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs)) + pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs)) + + + ENDIF ENDDO @@ -18701,7 +22892,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) - write(iunit,*) (qssbv(mgs)) + write(iunit,*) qssbv(mgs) write(iunit,*) Min(0.0, qscev(mgs)) write(iunit,*) -qsmul(mgs) ! @@ -18773,33 +22964,37 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & - & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & (qhmlr(mgs)+ & + & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & & +il5(mgs)*(1-imixedphase)*( & & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & & +qsshr(mgs) & & +qhshr(mgs) & - & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qiacr(mgs) & & ) & & +il5(mgs)*(qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs)) pmlt(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + & (qhmlr(mgs)+qsmlr(mgs)+ & + & qhlmlr(mgs)) !+qhmlh(mgs)) ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & - & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & + qssbv(mgs) + qhsbv(mgs) & + & + qhlsbv(mgs) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs) pevap(mgs) = & - & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) & + + Min(0.0,qfcev(mgs)) ! NOTE: pdep is the deposition part only pdep(mgs) = & & il5(mgs)*( & @@ -18827,7 +23022,7 @@ subroutine nssl_2mom_gs & & + qidpv(mgs) + qisbv(mgs) ) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) ELSE pfrz(mgs) = 0.0 psub(mgs) = 0.0 @@ -18855,6 +23050,8 @@ subroutine nssl_2mom_gs & ! ! do mgs = 1,ngscnt + + qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) qx(mgs,lc) = qx(mgs,lc) + & @@ -18867,6 +23064,7 @@ subroutine nssl_2mom_gs & & dtp*(pqswi(mgs)+pqswd(mgs)) qx(mgs,lh) = qx(mgs,lh) + & & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN qx(mgs,lhl) = qx(mgs,lhl) + & & dtp*(pqhli(mgs)+pqhld(mgs)) @@ -18936,12 +23134,32 @@ subroutine nssl_2mom_gs & + ENDIF + ENDIF + IF ( ipconc .ge. 6 ) THEN + IF ( lzr .gt. 1 ) THEN + zx(mgs,lr) = zx(mgs,lr) + & + & dtp*(pzrwi(mgs)+pzrwd(mgs)) + ENDIF + IF ( lzs .gt. 1 ) THEN + zx(mgs,ls) = zx(mgs,ls) + & + & dtp*(pzswi(mgs)+pzswd(mgs)) + ENDIF + IF ( lzh .gt. 1 ) THEN + zx(mgs,lh) = zx(mgs,lh) + & + & dtp*(pzhwi(mgs)+pzhwd(mgs)) + ENDIF + IF ( lzhl .gt. 1 ) THEN + zx(mgs,lhl) = zx(mgs,lhl) + & + & dtp*(pzhli(mgs)+pzhld(mgs)) +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF ENDIF ENDIF end do end if - IF ( has_wetscav ) THEN DO mgs = 1,ngscnt evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) @@ -19183,41 +23401,9 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN -! C$PAR CRITICAL SECTION -! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), -! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), -! : ltemq,igs(mgs),jy,kgs(mgs) -! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), -! : ab(igs(mgs),jy,kgs(mgs),lt), -! : t0(igs(mgs),jy,kgs(mgs)) -! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) -! STOP -! C$PAR END CRITICAL SECTION -! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) qis(mgs) = pqs(mgs)*tabqis(ltemq) -! qss(kz) = qvs(kz) -! if ( temg(kz) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) -! qss(kz) = qis(kz) -! end if -! dont get enough condensation with qcw .le./.gt. qxmin(lc) -! if ( temg(mgs) .lt. tfr ) then -! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) -! > qss(mgs) = qvs(mgs) -! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = qis(mgs) -! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / -! > (qx(mgs,lc) + qitmp(mgs)) -! else -! qss(mgs) = qvs(mgs) -! end if qss(mgs) = qvs(mgs) if ( temg(mgs) .lt. tfr ) then if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & @@ -19456,7 +23642,6 @@ subroutine nssl_2mom_gs & - if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -19487,6 +23672,29 @@ subroutine nssl_2mom_gs & ENDIF + + + +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il)) + lfsave(mgs,4) = zx(mgs,il) + ENDIF + + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il)) + + ENDIF + ENDDO + + ENDIF ! end do ! @@ -19551,11 +23759,466 @@ subroutine nssl_2mom_gs & ENDIF !} ENDDO ! mgs + ELSE ! } { is three-moment, so have to adjust Z if size is too large + IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN + +! rdmx = +! rdmn = + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN + tmp = cx(mgs,il) +! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.) +! STOP + IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + + + ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL + + + + DO mgs = 1,ngscnt + + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il)) + lfsave(mgs,6) = cx(mgs,il) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + IF ( cx(mgs,lhl) > cxmin ) THEN + frac = chxf(mgs,lhl)/cx(mgs,lhl) + ELSE + frac = 0.0 + ENDIF + ENDIF + + IF ( il == lh .and. lnhf > 1 ) THEN + IF ( cx(mgs,lh) > cxmin ) THEN + frach = chxf(mgs,lh)/cx(mgs,lh) + ELSE + frach = 0.0 + ENDIF + ENDIF + + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il) + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ELSE + IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + zx(mgs,il) = 0.0 + ENDIF + ENDIF !} + + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{ + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{ +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + +! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + +! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + ELSE + ! have all valid moments, so find shape parameter + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN !{ + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{ + tmp = cx(mgs,il) + + + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF !} + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{ + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + +! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! z = z1*(6./(pi*xdn(mgs,il)))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + + ENDIF !} + + ENDIF !} + + + ENDIF ! !} + + + + ENDIF !} + + IF ( lzr > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) )) + ENDIF + IF ( lzh > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) )) + ENDIF + IF ( lzhl > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) )) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lhl) = frac*cx(mgs,lhl) + ENDIF + IF ( il == lh .and. lnhf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lh) = frach*cx(mgs,lh) + ENDIF + + +! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN +! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6) +! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4) +! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs) +! +! ENDIF + + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + + +! CALL cld_cpu('Z-DELABK') + + + + + ENDIF ! } } + ENDIF ! }} ENDIF ! } DO mgs = 1,ngscnt + + IF ( il == lh ) THEN + IF ( lnhf > 1 ) THEN ! number of graupel from frozen drops + an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) + ENDIF + ENDIF + IF ( il == lhl ) THEN IF ( lnhlf > 1 ) THEN ! number of hail from frozen drops diff --git a/phys/module_mp_wdm6.F b/phys/module_mp_wdm6.F index 4ff157910c..4509fff847 100644 --- a/phys/module_mp_wdm6.F +++ b/phys/module_mp_wdm6.F @@ -383,6 +383,12 @@ subroutine wdm62D(t, q, qci, qrs, ncr, den, p, delz & ! nccn > 100 cm-3, bae from kiaps, oct 2017 ! bug fix hydrometeros update before condensation process of rain, ! bae from kiaps, oct2017 +! bug fix in snow melting and autoconversion. +! ==> Revisions enchance melting and autoconverison. +! hong from noaa, july 2023 +! remedy for tiny nc in the presence of qc (nc = xncr, 300/cm**3) +! ==> prevents the crash in computing autoconversion +! hong from noaa, july 2023 ! ! history log : ! @@ -586,7 +592,6 @@ subroutine wdm62D(t, q, qci, qrs, ncr, den, p, delz & dend(i,k) = den(i,k) enddo enddo - ! ! latent heat for phase changes and heat capacity. neglect the ! changes during microphysical process calculation @@ -904,8 +909,7 @@ subroutine wdm62D(t, q, qci, qrs, ncr, den, p, delz & 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.) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld,-qrs(i,k,2)),0.) !------------------------------------------------------------------- ! nsmlt: melting of snow [LH A27] ! (T>T0: ->NR) @@ -928,8 +932,7 @@ subroutine wdm62D(t, q, qci, qrs, ncr, den, p, delz & 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.) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld,-qrs(i,k,3)),0.) !------------------------------------------------------------------- ! ngmlt: melting of graupel [LH A28] ! (T>T0: ->NR) @@ -1165,7 +1168,7 @@ subroutine wdm62D(t, q, qci, qrs, ncr, den, p, delz & lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & *rslopec2(i,k)-0.4) lenconcr = max(1.2*lencon, qcrmin) - if(qci(i,k,1).gt.qcr(i,k)) then + if(qci(i,k,1).gt.qcr(i,k).and.ncr(i,k,2).gt.ncmin) then praut(i,k) = qck1*qci(i,k,1)**(7./3.)*ncr(i,k,2)**(-1./3.) praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) !---------------------------------------------------------------------- @@ -2109,7 +2112,7 @@ SUBROUTINE wdm6init(den0,denr,dens,cl,cpv, ccn0, hail_opt, allowed_to_read) ! RA ! qc0 = 4./3.*pi*denr*r0**3.*xncr0/den0 qc1 = 4./3.*pi*denr*r0**3.*xncr1/den0 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + qck1 = .104*9.8*peaut/(denr)**(1./3.)/xmyu*den0**(4./3.) ! 4706.08203 pidnc = pi*denr/6. ! bvtr1 = 1.+bvtr diff --git a/phys/module_mp_wdm7.F b/phys/module_mp_wdm7.F index e063038d78..d29374481c 100644 --- a/phys/module_mp_wdm7.F +++ b/phys/module_mp_wdm7.F @@ -380,6 +380,16 @@ SUBROUTINE wdm72D(t, q, qci, qrs, ncr, den, p, delz & ) !------------------------------------------------------------------- IMPLICIT NONE +! +! The code was first implemented in WRF in v4.1 +! Further Development: +! bug fix in snow melting and autoconversion. +! ==> Revisions enchance melting and autoconverison. +! hong from noaa, july2023 +! remedy for tiny nc in the presence of qc (nc = xncr, 300/cm**3) +! ==> prevents the crashed in computing autoconversion +! hong from noaa, july2023 +! !------------------------------------------------------------------- INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & @@ -916,8 +926,7 @@ SUBROUTINE wdm72D(t, q, qci, qrs, ncr, den, p, delz & 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.) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld,-qrs(i,k,2)),0.) ! ! nsmlt: melting of snow [LH A27] ! (T>T0: ->NR) @@ -939,8 +948,7 @@ SUBROUTINE wdm72D(t, q, qci, qrs, ncr, den, p, delz & 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.) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld,-qrs(i,k,3)),0.) ! ! ngmlt: melting of graupel [LH A28] ! (T>T0: ->NR) @@ -1212,7 +1220,7 @@ SUBROUTINE wdm72D(t, q, qci, qrs, ncr, den, p, delz & lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & *rslopec2(i,k)-0.4) lenconcr = max(1.2*lencon, qcrmin) - if(qci(i,k,1).gt.qcr(i,k)) then + if(qci(i,k,1).gt.qcr(i,k).and.ncr(i,k,2).gt.ncmin) then praut(i,k) = qck1*qci(i,k,1)**(7./3.)*ncr(i,k,2)**(-1./3.) praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) ! @@ -2381,7 +2389,7 @@ SUBROUTINE wdm7init(den0,denr,dens,cl,cpv, ccn0, allowed_to_read) ! RAS ! qc0 = 4./3.*pi*denr*r0**3.*xncr0/den0 qc1 = 4./3.*pi*denr*r0**3.*xncr1/den0 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + qck1 = .104*9.8*peaut/(denr)**(1./3.)/xmyu*den0**(4./3.) ! 4706.08203 pidnc = pi*denr/6. ! bvtr1 = 1.+bvtr diff --git a/phys/module_mp_wsm6.F b/phys/module_mp_wsm6.F index 3812b4282d..d0d45e69a2 100644 --- a/phys/module_mp_wsm6.F +++ b/phys/module_mp_wsm6.F @@ -1,2682 +1,240 @@ -#if ( (defined(wrfmodel) ) && ( RWORDSIZE == 4 ) ) || ( ( defined(mpas) ) && defined(SINGLE_PRECISION) ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -MODULE module_mp_wsm6 -! - USE module_mp_radar - USE module_model_constants, only : RE_QC_BG, RE_QI_BG, RE_QS_BG -! - 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 & -#if ( WRF_CHEM == 1) - ,wetscav_on, evapprod, rainprod & -#endif - ) -!------------------------------------------------------------------- - 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), OPTIONAL, & ! GT - INTENT(INOUT) :: refl_10cm -!+---+-----------------------------------------------------------------+ + module module_mp_wsm6 + use ccpp_kind_types,only: kind_phys - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv + use mp_wsm6,only: mp_wsm6_run + use mp_wsm6_effectrad,only: mp_wsm6_effectRad_run -#if ( WRF_CHEM == 1 ) - REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(INOUT) :: & - rainprod, & - evapprod - LOGICAL, INTENT(IN) :: wetscav_on - -! local variable - REAL, DIMENSION( its:ite , kts:kte ) :: & - rainprod2d, & - evapprod2d -#endif - -! 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 + implicit none + private + public:: wsm6 - 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 & -#if ( WRF_CHEM == 1) - ,wetscav_on, rainprod2d, evapprod2d & -#endif - ) - 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 + contains - 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) = RE_QC_BG - re_qi(k) = RE_QI_BG - re_qs(k) = RE_QS_BG - 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(RE_QC_BG, MIN(re_qc(k), 50.E-6)) - re_ice(i,k,j) = MAX(RE_QI_BG, MIN(re_qi(k), 125.E-6)) - re_snow(i,k,j) = MAX(RE_QS_BG, MIN(re_qs(k), 999.E-6)) - enddo - enddo - endif ! has_reqc, etc... -!+---+-----------------------------------------------------------------+ -#if( WRF_CHEM == 1 ) - if( wetscav_on ) then - do i=its,ite - do k=kts,kte - rainprod(i,k,j) = rainprod2d(i,k) - evapprod(i,k,j) = evapprod2d(i,k) - enddo - enddo - endif -#endif - 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 & -#if ( WRF_CHEM == 1 ) - ,wetscav_on, rainprod2d, evapprod2d & +!================================================================================================================= + 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 - ) -!------------------------------------------------------------------- - 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 - -#if ( WRF_CHEM == 1) - REAL, DIMENSION( its:ite , kts:kte ), INTENT(INOUT) :: & - rainprod2d, & - evapprod2d - LOGICAL, INTENT(IN) :: wetscav_on + ) +!================================================================================================================= + +!--- input arguments: + logical,intent(in),optional:: diagflag + + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: has_reqc,has_reqi,has_reqs + integer,intent(in),optional:: do_radar_ref + + real(kind=kind_phys),intent(in):: & + delt,g,rd,rv,t0c,den0,cpd,cpv,ep1,ep2,qmin,xls,xlv0,xlf0, & + cliq,cice,psat,denr + + real(kind=kind_phys),intent(in):: & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme ):: & + den, & + pii, & + p, & + delz + +!inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: & + rain,rainncv,sr + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + snow,snowncv + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + graupel,graupelncv + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + th, & + q, & + qc, & + qi, & + qr, & + qs, & + qg + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + re_cloud, & + re_ice, & + re_snow + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + refl_10cm + +#if(WRF_CHEM == 1) + logical,intent(in):: wetscav_on + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme ):: & + rainprod,evapprod + real(kind=kind_phys),dimension(its:ite,kts:kte):: rainprod_hv,evapprod_hv #endif -! 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. - ! reduce collection efficiency (suggested by B. Wilt) - praci(i,k) = praci(i,k)*min(max(0.0,qrs(i,k,1)/qci(i,k,2)),1.)**2 - 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) - ! reduce collection efficiency (suggested by B. Wilt) - piacr(i,k) = piacr(i,k)*min(max(0.0,qci(i,k,2)/qrs(i,k,1)),1.)**2 - 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) & - ! reduce collection efficiency (suggested by B. Wilt) - *min(max(0.0,qrs(i,k,2)/qci(i,k,1)),1.)**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) & - ! reduce collection efficiency (suggested by B. Wilt) - *min(max(0.0,qrs(i,k,3)/qci(i,k,1)),1.)**2 & - *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 - ! reduce collection efficiency (suggested by B. Wilt) - pracs(i,k) = pracs(i,k)*min(max(0.0,qrs(i,k,1)/qrs(i,k,2)),1.)**2 - 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 - ! reduce collection efficiency (suggested by B. Wilt) - psacr(i,k) = psacr(i,k)*min(max(0.0,qrs(i,k,2)/qrs(i,k,1)),1.)**2 - 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 - ! reduce collection efficiency (suggested by B. Wilt) - pgacr(i,k) = pgacr(i,k)*min(max(0.0,qrs(i,k,3)/qrs(i,k,1)),1.)**2 - 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 - -#if( WRF_CHEM == 1 ) - if( wetscav_on ) then - rainprod2d = praut+pracw+praci+psaci+pgaci+psacw+pgacw+paacw+psaut - evapprod2d = -(prevp+psevp+pgevp+psdep+pgdep) - endif -#endif - - 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 - -! 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 - -!+---+-----------------------------------------------------------------+ -!..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 -!+---+-----------------------------------------------------------------+ - -! - 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 - -!..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 - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL:: melti - - DOUBLE PRECISION:: cback, x, eta, f_d - REAL, PARAMETER:: R=287. - -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..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)) - - 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 - - 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 - - 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 - -!+---+-----------------------------------------------------------------+ -!..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 - -!+---+-----------------------------------------------------------------+ -!..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. -!+---+-----------------------------------------------------------------+ +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg - 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 +!local variables and arrays: + logical:: do_microp_re + integer:: i,j,k + real(kind=kind_phys),dimension(kts:kte):: qv1d,t1d,p1d,qr1d,qs1d,qg1d,dBZ + real(kind=kind_phys),dimension(kts:kte):: den1d,qc1d,qi1d,re_qc,re_qi,re_qs -!+---+-----------------------------------------------------------------+ -!..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). -!+---+-----------------------------------------------------------------+ + real(kind=kind_phys),dimension(its:ite):: rainncv_hv,rain_hv,sr_hv + real(kind=kind_phys),dimension(its:ite):: snowncv_hv,snow_hv + real(kind=kind_phys),dimension(its:ite):: graupelncv_hv,graupel_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: t_hv,den_hv,p_hv,delz_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,qr_hv,qs_hv,qg_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: re_qc_hv,re_qi_hv,re_qs_hv - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 +!----------------------------------------------------------------------------------------------------------------- -!..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 - - -!..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=evapprod_hv & +#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/phys/module_pbl_driver.F b/phys/module_pbl_driver.F index fd2075f45b..f703071765 100644 --- a/phys/module_pbl_driver.F +++ b/phys/module_pbl_driver.F @@ -28,6 +28,7 @@ SUBROUTINE pbl_driver( & ,kpbl,mixht,ct,lh,snow,xice & ,znu, znw, mut, p_top & ,ctopo,ctopo2,windfarm_opt,power & + ,windfarm_wake_model, windfarm_overlap_method & ,ysu_topdown_pblmix & ,shinhong_tke_diag & ! OPTIONAL for TEMF scheme @@ -39,7 +40,7 @@ SUBROUTINE pbl_driver( & ,flhc,flqc & ! MYNN ,qke,Sh3d,Sm3d & - ,qke_adv,bl_mynn_tkeadvect & !ACF for QKE advection + ,qke_adv,bl_mynn_tkeadvect & ,tsq,qsq,cov,rmol,ch,qcg,grav_settling & ,dqke,qWT,qSHEAR,qBUOY,qDISS,tke_budget & ,bl_mynn_closure,bl_mynn_cloudpdf & @@ -53,7 +54,7 @@ SUBROUTINE pbl_driver( & ,sub_thl3D,sub_sqv3D & ,det_thl3D,det_sqv3D & ,vdfg & - ,nupdraft,maxMF,ktop_plume & + ,maxwidth,maxMF,ztop_plume,ktop_plume & ,spp_pbl,pattern_spp_pbl & ! EEPS ,pek,pep,pek_adv,pep_adv & @@ -103,6 +104,9 @@ SUBROUTINE pbl_driver( & ,tke_adv,diss_adv,tpe_adv & ,pr_pbl,el_pbl & ,wu_tur,wv_tur,wt_tur,wq_tur & +! variables added for AHE + , gmt, xtime, julday, julyr, ahe & + , distributed_ahe_opt & ! variables for GBM PBL ,exch_tke, rthraten & ,a_e_bep,b_e_bep,dlg_bep,dl_u_bep & @@ -155,6 +159,7 @@ SUBROUTINE pbl_driver( & CAMUWPBLSCHEME,BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, & FITCHSCHEME,SHINHONGSCHEME, & TEMFPBLSCHEME,GBMPBLSCHEME,EEPSSCHEME,KEPSSCHEME, & + MAVSCHEME, & ! Yulong add for WLM CAMMGMPSCHEME,p_qi,p_qni,p_qnc,param_first_scalar,& !CAMMGMPSCHEME, p_qni,p_qnc is used for camuwpbl scheme p_qnwfa,p_qnifa,p_qnbca #if ( WRFPLUS == 1 ) @@ -167,6 +172,7 @@ SUBROUTINE pbl_driver( & , TEMFPBLSCHEME, GFSEDMFSCHEME & , CAMUWPBLSCHEME & , FITCHSCHEME, SHINHONGSCHEME & + , MAVSCHEME ! Yulong add for WLM , GBMPBLSCHEME, MYJSFCSCHEME #endif @@ -198,7 +204,9 @@ SUBROUTINE pbl_driver( & USE module_bl_keps USE module_bl_fogdes USE module_wind_fitch + USE module_wind_mav ! Yulong add for WLM #endif + use module_ra_gfdleta, only: cal_mon_day ! This driver calls subroutines for the PBL parameterizations. ! @@ -434,6 +442,9 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN), OPTIONAL :: xlat_u,xlong_u,xlat_v,xlong_v + ! Yulong add for WLM + INTEGER, INTENT(IN ) :: windfarm_wake_model, windfarm_overlap_method + REAL, DIMENSION( ims:ime, kms:kme ,jms:jme ), & INTENT(IN), OPTIONAL :: w ! @@ -585,9 +596,9 @@ SUBROUTINE pbl_driver( & & INTENT(INOUT):: vdfg INTEGER, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & - & INTENT(OUT) :: nupdraft,ktop_plume + & INTENT(OUT) :: ktop_plume REAL, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & - & INTENT(OUT) :: maxMF + & INTENT(OUT) :: maxwidth,maxMF,ztop_plume REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: qnwfa_curr,qnifa_curr,qnbca_curr @@ -610,6 +621,11 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(OUT) :: EL_PBL + REAL, INTENT(IN) :: gmt, xtime + INTEGER, INTENT(IN) :: julday, julyr + REAL, OPTIONAL, DIMENSION( ims:ime, 0:287, jms:jme ), INTENT(IN) :: ahe + INTEGER, INTENT(IN) :: distributed_ahe_opt + REAL , INTENT(IN ) :: u_frame, & v_frame ! @@ -820,6 +836,8 @@ SUBROUTINE pbl_driver( & integer iu_bep,iurb,idiff real seamask,thsk,zzz,unew,vnew,tnew,qnew,umom,vmom REAL :: z0,z1,z2,w1,w2 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: TKE_windfarm ! Yulong add for WLM + INTEGER :: ihour, jmonth, jday ! ! FASDAS ! @@ -829,6 +847,10 @@ SUBROUTINE pbl_driver( & ! ! END FASDAS ! +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg +! !------------------------------------------------------------------ ! !!!!!!!if using BEP set flag_bep to true @@ -1193,13 +1215,13 @@ SUBROUTINE pbl_driver( & PRESENT( hol ) ) THEN ! CALL ysu( & - U3D=u_phytmp,V3D=v_phytmp,TH3D=th_phy,T3D=t_phy & + U3D=u_phytmp,V3D=v_phytmp,T3D=t_phy & ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr & ,P3D=p_phy,P3DI=p8w,PI3D=pi_phy & ,RUBLTEN=rublten,RVBLTEN=rvblten & ,RTHBLTEN=rthblten,RQVBLTEN=rqvblten & ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & - ,FLAG_QI=flag_qi & + ,FLAG_QI=flag_qi,FLAG_QC=flag_qc & ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg & ,DZ8W=dz8w,XLV=XLV,RV=r_v,PSFC=PSFC & ,ZNT=znt,UST=ust,HPBL=pblh & @@ -1212,7 +1234,7 @@ SUBROUTINE pbl_driver( & ,YSU_TOPDOWN_PBLMIX=ysu_topdown_pblmix & ,WSPD=wspd,BR=br,DT=dtbl,KPBL2D=kpbl & ,EP1=ep_1,EP2=ep_2,KARMAN=karman & - ,EXCH_H=exch_h,EXCH_M=exch_m,REGIME=regime & + ,EXCH_H=exch_h,EXCH_M=exch_m & ,RTHRATEN=RTHRATEN & ! for multilayer UCM ,IDIFF=idiff,FLAG_BEP=flag_bep,FRC_URB2D=frc_urb2d & @@ -1224,6 +1246,7 @@ SUBROUTINE pbl_driver( & ,DL_U_BEP=dl_u_bep,SF_BEP=sf_bep,VL_BEP=vl_bep & ! for grims shallow convection with ysupbl ,WSTAR=wstar,DELTA=delta & + ,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 & @@ -1638,7 +1661,7 @@ SUBROUTINE pbl_driver( & &initflag=initflag,restart=restart,cycling=cycling, & &delt=dtbl,dz=dz8w,dxc=dx,znt=znt, & &u=u_phy,v=v_phy,w=w,th=th_phy,qv=qv_curr, & - &qc=qc_curr,qi=qi_curr, & + &qc=qc_curr,qi=qi_curr,qs=qs_curr, & &qnc=qnc_curr,qni=qni_curr, & &QNWFA=qnwfa_curr,QNIFA=qnifa_curr,QNBCA=qnbca_curr, & ! &ozone=ozone, & @@ -1658,6 +1681,7 @@ SUBROUTINE pbl_driver( & &RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten, & &RQVBLTEN=rqvblten,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten,& &RQNCBLTEN=rqncblten,RQNIBLTEN=rqniblten, & + &RQSBLTEN=rqsblten, & &RQNWFABLTEN=rqnwfablten,RQNIFABLTEN=rqnifablten, & &RQNBCABLTEN=rqnbcablten, & ! &Ro3BLTEN=ro3blten, & @@ -1671,8 +1695,8 @@ SUBROUTINE pbl_driver( & &edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc, & &sub_thl3D=sub_thl3D,sub_sqv3D=sub_sqv3D, & &det_thl3D=det_thl3D,det_sqv3D=det_sqv3D, & - &nupdraft=nupdraft,maxMF=maxMF, & - &ktop_plume=ktop_plume, & + &maxwidth=maxwidth,maxMF=maxMF, & + &ztop_plume=ztop_plume,ktop_plume=ktop_plume, & &RTHRATEN=RTHRATEN, & &bl_mynn_tkeadvect=bl_mynn_tkeadvect, & &tke_budget=tke_budget, & @@ -1688,7 +1712,7 @@ SUBROUTINE pbl_driver( & &bl_mynn_mixqt=bl_mynn_mixqt, & &bl_mynn_closure=bl_mynn_closure, & &spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl, & - &FLAG_QC=flag_qc,FLAG_QI=flag_qi, & + &FLAG_QC=flag_qc,FLAG_QI=flag_qi,FLAG_QS=flag_qs, & &FLAG_QNC=flag_qnc,FLAG_QNI=flag_qni, & &FLAG_QNWFA=flag_qnwfa,FLAG_QNIFA=flag_qnifa, & &FLAG_QNBCA=flag_qnbca, & @@ -2061,6 +2085,47 @@ SUBROUTINE pbl_driver( & CALL wrf_error_fatal('Lack arguments to call turbine_drag') ENDIF + ! Yulong add new wind farm schemes with wind turbine loss effect + CASE (mavscheme) + IF (PRESENT(id) .AND. & + PRESENT(z_at_w) ) THEN + CALL wrf_debug(100,'in phys/module_wind_mav.F') + CALL dragforce_mav(itimestep & + &,ID=id & + &,Z_AT_W=z_at_w,z_at_m=z,u=u_phy,v=v_phy & + &,DX=dx,DZ=dz8w,DT=dt & + &,TKE=TKE_windfarm & + &,DU=rublten,DV=rvblten & + &,WINDFARM_OPT=windfarm_opt,POWER=power & + &,windfarm_wake_model=windfarm_wake_model & + &,windfarm_overlap_method=windfarm_overlap_method & + &,xland=xland & + &,cosa=cosa,sina=sina & + &,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 (bl_mynn_tkeadvect) THEN + QKE = QKE + 2.*TKE_windfarm + qke_adv=qke + ENDIF + + ELSE + WRITE ( message , FMT = '(A,6(L1,1X))' ) & + 'present: '// & + 'ID, '// & + 'z_at_w, '// & + 'xlat_u, '// & + 'xlong_u, '// & + 'xlat_v, '// & + 'xlong_v = ' , & + PRESENT( id ) , & + PRESENT( z_at_w ) + CALL wrf_debug(0,message) + CALL wrf_error_fatal('Lack arguments to call dragforce_mav') + ENDIF + END SELECT windfarm_select #endif @@ -2082,7 +2147,8 @@ SUBROUTINE pbl_driver( & ,ZNU=znu,ZNW=znw,P_TOP=p_top & ,CP=cp,G=g,RD=r_d & ,RV=r_v,EP1=ep_1,PI=3.141592653 & - ,DT=dtbl,DX=dx,KPBL2D=kpbl,ITIMESTEP=itimestep & + ,DT=dtbl,DX=dx2d,KPBL2D=kpbl,ITIMESTEP=itimestep & + ,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 ) @@ -2203,6 +2269,17 @@ SUBROUTINE pbl_driver( & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte) ENDIF + IF (distributed_ahe_opt == 1) THEN + call cal_mon_day(julday, julyr, jmonth, jday) + ihour = (jmonth - 1) * 24 + MOD(INT(gmt + xtime / 60.0), 24) + DO j = jts, jte + DO i = its, ite + ! Volumetric heat capacity of air = 1200 J/(K m3) + RTHBLTEN(i, 1, j) = RTHBLTEN(i, 1, j) + ahe(i, ihour, j) / 1200 / DZ8W(i, 1, j) + END DO + END DO + END IF + ENDDO !$OMP END PARALLEL DO diff --git a/phys/module_physics_init.F b/phys/module_physics_init.F index e26df70a7d..9d419edf7d 100644 --- a/phys/module_physics_init.F +++ b/phys/module_physics_init.F @@ -233,15 +233,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & t00, p00, tlp, & !for obs-nudging TYR,TYRA,TDLY,TLAG,NYEAR,NDAY,tmn_update, & ACHFX,ACLHF,ACGRDFLX, & - nssl_cccn, & - nssl_alphah,nssl_alphahl, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs, & -! next 2 flags for Explicit lightning: - nssl_ipelec, & - nssl_isaund, & ! OPTIONAL RQCNCUTEN, RQINCUTEN, & rliq, & !BSINGH:01/31/2013 - Added rliq and is_CAMMGMP_used for CAM5 physics @@ -293,6 +284,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & USE module_cam_support, ONLY : cam_mam_aerosols #endif USE module_wind_fitch + USE module_wind_mav ! Yulong add for WLM IMPLICIT NONE !----------------------------------------------------------------- TYPE (grid_config_rec_type) :: config_flags @@ -825,13 +817,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & TYPE(fdob_type), OPTIONAL, INTENT(INOUT) :: fdob #endif REAL, OPTIONAL, INTENT(IN) :: p00, t00, tlp ! for obs-nudging base-state calcn - REAL, INTENT(IN) :: nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs - - INTEGER, INTENT(IN) :: nssl_ipelec,nssl_isaund ! WA 12/21/09 REAL,OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & @@ -1019,9 +1004,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & (config_flags%ra_sw_physics .eq. goddardswscheme ) ) .and. & (config_flags%mp_physics .eq. THOMPSON .or. & config_flags%mp_physics .eq. THOMPSONAERO .or. & - config_flags%mp_physics .eq. NSSL_2MOM .or. & - config_flags%mp_physics .eq. NSSL_2MOMG .or. & - config_flags%mp_physics .eq. NSSL_2MOMCCN .or. & + (config_flags%mp_physics .eq. NSSL_2MOM .and. config_flags%nssl_2moment_on == 1) .or. & config_flags%mp_physics .eq. WSM3SCHEME .or. & config_flags%mp_physics .eq. WSM5SCHEME .or. & config_flags%mp_physics .eq. WSM6SCHEME .or. & @@ -1412,6 +1395,10 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & ! IF ( config_flags%windfarm_opt .EQ. 1 ) THEN CALL init_module_wind_fitch(id,config_flags,xlong,xlat,windfarm_initialized,ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde) + ! --- Yulong --- + ELSEIF ( config_flags%windfarm_opt .EQ. 2 ) THEN + CALL init_module_wind_mav(id,config_flags,xlong,xlat,windfarm_initialized, & + dx,ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde) ENDIF CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to ra_init' ) @@ -1657,12 +1644,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & allowed_to_read, start_of_simulation, & !CAMMGMP specific variables ixcldliq, ixcldice, ixnumliq, ixnumice, & - nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_ipelec, nssl_isaund, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs, & ccn_conc, & ! RAS z_at_q, inv_dens, qnwfa2d, qnbca2d, & ! G. Thompson frc_urb2d, scalar, num_sc, & ! G. Thompson @@ -2641,7 +2622,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & ) !Optional oml !-------------------------------------------------------------------- USE module_sf_sfclay - USE module_sf_sfclayrev + USE sf_sfclayrev USE module_sf_slab USE module_sf_pxsfclay USE module_bl_ysu @@ -3108,6 +3089,10 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & INTEGER,OPTIONAL,INTENT(OUT), DIMENSION( ims:ime,jms:jme):: irr_rand_field INTEGER,OPTIONAL :: irr_ph,irr_freq +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + #if ( EM_CORE == 1 ) !local mynn INTEGER :: mynn_closure_level @@ -3156,11 +3141,14 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CALL sfclayinit( allowed_to_read ) isfc = 1 CASE (SFCLAYREVSCHEME) - CALL sfclayrevinit(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) + CALL sf_sfclayrev_init(errmsg,errflg) + IF ( shalwater_z0 .EQ. 1 ) THEN + CALL shalwater_init(ims,ime,jms,jme, & + its,ite,jts,jte, & + bathymetry_flag, shalwater_z0, & + shalwater_depth, water_depth, & + xland,LakeModel,lake_depth,lakemask ) + END IF isfc = 1 CASE (PXSFCSCHEME) CALL pxsfclayinit( allowed_to_read ) @@ -3302,8 +3290,8 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & IF ( PRESENT( FRC_URB2D ) .AND. PRESENT( UTYPE_URB2D )) THEN CALL urban_param_init(DZR,DZB,DZG,num_soil_layers, & !urban - sf_urban_physics,config_flags%use_wudapt_lcz) !urban - + sf_urban_physics,config_flags%use_wudapt_lcz, & + config_flags%slucm_distributed_drag) CALL urban_var_init(ISURBAN,TSK,TSLB,TMN,IVGTYP, & !urban ims,ime,jms,jme,kms,kme,num_soil_layers, & !urban @@ -3445,7 +3433,8 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & IF ((SF_URBAN_PHYSICS.eq.1).OR.(SF_URBAN_PHYSICS.EQ.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN IF ( PRESENT( FRC_URB2D ) .AND. PRESENT( UTYPE_URB2D )) THEN CALL urban_param_init(DZR,DZB,DZG,num_soil_layers, & !urban - sf_urban_physics,config_flags%use_wudapt_lcz) + sf_urban_physics,config_flags%use_wudapt_lcz, & + config_flags%slucm_distributed_drag) CALL urban_var_init(ISURBAN,TSK,TSLB,TMN,IVGTYP, & !urban ims,ime,jms,jme,kms,kme,num_soil_layers, & !urban LCZ_1_TABLE,LCZ_2_TABLE,LCZ_3_TABLE,LCZ_4_TABLE, & !urban @@ -3531,7 +3520,8 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CASE (PXLSMSCHEME) if(config_flags%num_land_cat .ne. 20 .and. config_flags%num_land_cat .ne. 21 .and. & ! MODIS config_flags%num_land_cat .ne. 24 .and. config_flags%num_land_cat .ne. 28 .and. & ! USGS - config_flags%num_land_cat .ne. 40 .and. config_flags%num_land_cat .ne. 50 ) & ! NLCD + config_flags%num_land_cat .ne. 40 .and. config_flags%num_land_cat .ne. 50 .and. & ! NLCD + config_flags%num_land_cat .ne. 61 ) & ! MODIS W/LCZ CALL wrf_error_fatal ( 'module_physics_init: PX LSM option requires USGS, MODIS, or NLCD' ) CALL LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, & @@ -3709,14 +3699,6 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CASE (YSUSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) - CALL ysuinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - RQCBLTEN,RQIBLTEN,P_QI, & - PARAM_FIRST_SCALAR, & - restart, & - allowed_to_read , & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) CASE (SHINHONGSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) @@ -4390,12 +4372,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, allowed_to_read, start_of_simulation, & !CAMMGMP specific variables ixcldliq, ixcldice, ixnumliq, ixnumice, & - nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_ipelec, nssl_isaund, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs, & ccn_conc, & ! RAS z_at_q, inv_dens, qnwfa2d, qnbca2d, & ! G. Thompson frc_urb2d, scalar, num_sc, & ! G. Thompson @@ -4405,7 +4381,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, !------------------------------------------------------------------ USE module_mp_wsm3 USE module_mp_wsm5 - USE module_mp_wsm6 + USE mp_wsm6 USE module_mp_wsm7 USE module_mp_etanew USE module_mp_fer_hires @@ -4425,7 +4401,9 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, USE module_mp_wdm5 USE module_mp_wdm6 USE module_mp_wdm7 +#if (WRFPLUS != 1) & !defined( VAR4D ) USE module_mp_nssl_2mom, only: nssl_2mom_init +#endif #if (EM_CORE==1) USE module_mp_cammgmp_driver, ONLY:CAMMGMP_INIT !CAM5's microphysics USE module_mp_morr_two_moment_aero !TWG2017 @@ -4439,12 +4417,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, LOGICAL , INTENT(IN) :: restart LOGICAL , INTENT(OUT) :: warm_rain,adv_moist_cond REAL , INTENT(IN) :: MPDT, DT, DX, DY - REAL, INTENT(IN), OPTIONAL :: nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_cnoh, nssl_cnohl, & - nssl_cnor, nssl_cnos, & - nssl_rho_qh, nssl_rho_qhl, & - nssl_rho_qs - INTEGER, INTENT(IN), OPTIONAL :: nssl_ipelec, nssl_isaund LOGICAL , INTENT(IN) :: start_of_simulation INTEGER , INTENT(IN) :: ixcldliq, ixcldice, ixnumliq, ixnumice ! CAMMGMP specific variables @@ -4476,9 +4448,14 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ! Local INTEGER :: i, j, itf, jtf REAL, DIMENSION(20) :: nssl_params - INTEGER :: nssl_ipelec_tmp + INTEGER :: nssl_ipelec_tmp, nssl_ipconc + logical :: nssl_density_on INTEGER :: i_err +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + warm_rain = .false. adv_moist_cond = .true. itf=min0(ite,ide-1) @@ -4494,33 +4471,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ENDDO ENDIF - IF ( present( nssl_cccn ) ) THEN - SELECT CASE(config_flags%mp_physics) - CASE (NSSL_2MOM,NSSL_2MOMCCN) - IF ( config_flags%elec_physics > 0 ) THEN - nssl_ipelec_tmp = nssl_ipelec - ELSE - nssl_ipelec_tmp = 0.0 - ENDIF - CASE DEFAULT - nssl_ipelec_tmp = 0.0 - END SELECT - - nssl_params(1) = nssl_cccn - nssl_params(2) = nssl_alphah - nssl_params(3) = nssl_alphahl - nssl_params(4) = nssl_cnoh - nssl_params(5) = nssl_cnohl - nssl_params(6) = nssl_cnor - nssl_params(7) = nssl_cnos - nssl_params(8) = nssl_rho_qh - nssl_params(9) = nssl_rho_qhl - nssl_params(10) = nssl_rho_qs - nssl_params(11) = nssl_ipelec_tmp - nssl_params(12) = nssl_isaund - - ENDIF - mp_select: SELECT CASE(config_flags%mp_physics) CASE (KESSLERSCHEME) @@ -4534,7 +4484,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, CASE (WSM5SCHEME) CALL wsm5init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read ) CASE (WSM6SCHEME) - CALL wsm6init(rhoair0,rhowater,rhosnow,cliq,cpv, config_flags%hail_opt,allowed_to_read ) + CALL mp_wsm6_init(rhoair0,rhowater,rhosnow,cliq,cpv,config_flags%hail_opt,errmsg,errflg) CASE (WSM7SCHEME) CALL wsm7init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read ) CASE (ETAMPNEW) @@ -4653,17 +4603,53 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, END IF # endif #endif - CASE (NSSL_1MOMLFO) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=0,mixphase=0,ihvol=-1) ! no separate hail - CASE (NSSL_1MOM) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=0,mixphase=0,ihvol=0) CASE (NSSL_2MOM) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) - CASE (NSSL_2MOMG) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=-1) ! turn off hail - CASE (NSSL_2MOMCCN) - ccn_conc = nssl_cccn/1.225 ! set this to have correct boundary conditions - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) +! Single generalized case (mp_physics=18) replaces previously separate mp_physics values of 17,18,19,20,22 +#if (WRFPLUS != 1) & !defined( VAR4D ) + + IF ( config_flags%elec_physics > 0 ) THEN + nssl_ipelec_tmp = config_flags%nssl_ipelec + ELSE + nssl_ipelec_tmp = 0.0 + ENDIF + + nssl_params(:) = 0 + nssl_params(1) = config_flags%nssl_cccn + nssl_params(2) = config_flags%nssl_alphah + nssl_params(3) = config_flags%nssl_alphahl + nssl_params(4) = config_flags%nssl_cnoh + nssl_params(5) = config_flags%nssl_cnohl + nssl_params(6) = config_flags%nssl_cnor + nssl_params(7) = config_flags%nssl_cnos + nssl_params(8) = config_flags%nssl_rho_qh + nssl_params(9) = config_flags%nssl_rho_qhl + nssl_params(10) = config_flags%nssl_rho_qs + nssl_params(11) = nssl_ipelec_tmp + nssl_params(12) = config_flags%nssl_isaund + nssl_params(13) = 0 ! reserved + nssl_params(14) = 0 ! reserved + nssl_params(15) = 0 ! reserved + + IF ( config_flags%nssl_2moment_on == 0 ) THEN + nssl_ipconc = 0 + ELSE + IF ( config_flags%nssl_3moment > 0 ) THEN + nssl_ipconc = 8 + ELSE + nssl_ipconc = 5 + ENDIF + ENDIF + + IF ( config_flags % nssl_ccn_on > 0 ) THEN + ccn_conc = config_flags%nssl_cccn/1.225 ! set this to have correct boundary conditions + ENDIF + CALL nssl_2mom_init(nssl_params=nssl_params,ipctmp=nssl_ipconc,mixphase=0, & + nssl_density_on=(config_flags%nssl_density_on > 0), & + nssl_hail_on=config_flags%nssl_hail_on > 0, & + nssl_ccn_on=(config_flags%nssl_ccn_on > 0), & + nssl_icdx=config_flags%nssl_icdx, & + nssl_icdxhl=config_flags%nssl_icdxhl,ccn_is_ccna=config_flags%nssl_ccn_is_ccna) +#endif #if (EM_CORE==1) CASE (CAMMGMPSCHEME) ! CAM5's microphysics CALL CAMMGMP_INIT(ixcldliq, ixcldice, ixnumliq, ixnumice & @@ -5677,4 +5663,61 @@ subroutine compute_2d_dx_area(dx, dy, msftx, msfty, dx2d, area2d, & end subroutine compute_2d_dx_area + SUBROUTINE shalwater_init(ims,ime,jms,jme, & + its,ite,jts,jte, & + bathymetry_flag, shalwater_z0, & + shalwater_depth, water_depth, & + xland,LakeModel,lake_depth,lakemask ) + + INTEGER, INTENT(IN) :: ims,ime,jms,jme,its,ite,jts,jte + INTEGER, INTENT(IN) :: shalwater_z0 + REAL, INTENT(IN) :: shalwater_depth + INTEGER, INTENT(IN) :: bathymetry_flag + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: water_depth + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xland + INTEGER :: LakeModel + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lake_depth + REAL, DIMENSION( ims:ime, jms:jme ) :: lakemask + + ! Local + LOGICAL :: overwrite_water_depth + overwrite_water_depth = .False. + + IF ( bathymetry_flag .eq. 1 ) THEN + IF ( shalwater_depth .LE. 0.0 ) THEN + IF ( LakeModel .ge. 1 ) THEN + + DO j = jts,jte + DO i = its,ite + IF ( lakemask(i,j) .EQ. 1 ) THEN + water_depth(i,j) = lake_depth(i,j) + END IF + END DO + END DO + END IF + ELSE + overwrite_water_depth = .True. + END IF + ELSE + IF ( shalwater_depth .GT. 0.0 ) THEN + overwrite_water_depth = .True. + ELSE + CALL wrf_error_fatal('No bathymetry data detected and shalwater_depth not greater than 0.0. Re-run WPS to get bathymetry data or set shalwater_depth > 0.0') + END IF + END IF + + IF (overwrite_water_depth) THEN + DO j = jts,jte + DO i = its,ite + IF((XLAND(i,j)-1.5).GE.0)THEN + water_depth(i,j) = shalwater_depth + ELSE + water_depth(i,j) = -2.0 + END IF + END DO + END DO + END IF + + END SUBROUTINE shalwater_init + END MODULE module_physics_init diff --git a/phys/module_ra_rrtmg_lw.F b/phys/module_ra_rrtmg_lw.F index eb8023bc40..6b5dc2d342 100644 --- a/phys/module_ra_rrtmg_lw.F +++ b/phys/module_ra_rrtmg_lw.F @@ -2537,6 +2537,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale ! compute alpha + ! todo - need to permute this loop after adding vectorized expf() function do i = 1, ncol alpha(i, 1) = 0._rb do ilev = 2,nlay @@ -3280,6 +3281,7 @@ subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & icldlyr(lay) = 0 ! Change to band loop? +! todo permute, remove condition, vectorize expf do ig = 1, ngptlw if (cldfmc(ig,lay) .eq. 1._rb) then ib = ngb(ig) diff --git a/phys/module_ra_rrtmg_sw.F b/phys/module_ra_rrtmg_sw.F index c0eb328a4d..1149bf8c28 100644 --- a/phys/module_ra_rrtmg_sw.F +++ b/phys/module_ra_rrtmg_sw.F @@ -1845,6 +1845,7 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale ! compute alpha + ! permute this loop do i = 1, ncol alpha(i, 1) = 0._rb do ilev = 2,nlay @@ -8597,28 +8598,36 @@ subroutine spcvmc_sw & zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk) ! /\/\/\ Above code only needed for direct beam calculation + enddo - +! to vectorize the following loop + do jk=1, klev ! Delta scaling - clear zf = zgcc(jk) * zgcc(jk) zwf = zomcc(jk) * zf ztauc(jk) = (1.0_rb - zwf) * ztauc(jk) zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf) zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf) + enddo ! Total sky optical parameters (cloud properties already delta-scaled) ! Use this code if cloud properties are derived in rrtmg_sw_cldprop if (icpr .ge. 1) then + do jk=1,klev + ikl=klev+1-jk ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw) zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + & ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk) zomco(jk) = zomco(jk) / ztauo(jk) + enddo ! Total sky optical parameters (if cloud properties not delta scaled) ! Use this code if cloud properties are not derived in rrtmg_sw_cldprop elseif (icpr .eq. 0) then + do jk=1,klev + ikl=klev+1-jk ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw) zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + & ztaur(ikl,iw) * 1.0_rb @@ -8633,10 +8642,10 @@ subroutine spcvmc_sw & ztauo(jk) = (1._rb - zwf) * ztauo(jk) zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf) zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf) + enddo endif ! End of layer loop - enddo ! Clear sky reflectivities call reftra_sw (klev, & @@ -8734,22 +8743,27 @@ subroutine spcvmc_sw & pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw) pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + enddo ! Accumulate direct fluxes for UV/visible bands if (ibm >= 10 .and. ibm <= 13) then + do jk=1,klev+1 + ikl=klev+2-jk puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw) puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw) puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) + enddo ! Accumulate direct fluxes for near-IR bands else if (ibm == 14 .or. ibm <= 9) then + do jk=1,klev+1 + ikl=klev+2-jk pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw) pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw) pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) - endif - enddo + endif ! End loop on jg, g-point interval enddo @@ -9429,8 +9443,8 @@ subroutine rrtmg_sw & ! enddo ! enddo - do i = 1, nlayers - do ib = 1, nbndsw + do ib = 1, nbndsw + do i = 1, nlayers ztaua(i,ib) = 0._rb zasya(i,ib) = 0._rb zomga(i,ib) = 0._rb @@ -9453,8 +9467,8 @@ subroutine rrtmg_sw & ! IAER=10: Direct specification of aerosol optical properties from GCM elseif (iaer.eq.10) then - do i = 1 ,nlayers - do ib = 1 ,nbndsw + do ib = 1 ,nbndsw + do i = 1 ,nlayers ztaua(i,ib) = taua(i,ib) ztauacln(i,ib) = 0.0 zasya(i,ib) = asma(i,ib) @@ -9934,8 +9948,8 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, & ! modify to reverse layer indexing here if necessary. if (iaer .ge. 1) then - do l = 1, nlayers - do ib = 1, nbndsw + do ib = 1, nbndsw + do l = 1, nlayers taua(l,ib) = tauaer(iplon,l,ib) ssaa(l,ib) = ssaaer(iplon,l,ib) asma(l,ib) = asmaer(iplon,l,ib) diff --git a/phys/module_radiation_driver.F b/phys/module_radiation_driver.F index 924c820086..1421cbd34f 100644 --- a/phys/module_radiation_driver.F +++ b/phys/module_radiation_driver.F @@ -1405,8 +1405,8 @@ SUBROUTINE radiation_driver ( & CALL wrf_debug (1, 'in rad driver; use BL clouds') IF (itimestep .NE. 1) THEN DO j = jts,jte - DO i = its,ite DO k = kts,kte + DO i = its,ite CLDFRA(i,k,j)=CLDFRA_BL(i,k,j) ENDDO ENDDO @@ -1414,13 +1414,13 @@ SUBROUTINE radiation_driver ( & ENDIF DO j = jts,jte - DO i = its,ite DO k = kts,kte + DO i = its,ite IF (qc(i,k,j) < 1.E-6 .AND. CLDFRA_BL(i,k,j) > 0.001) THEN - qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j)*CLDFRA_BL(i,k,j) + qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j) ENDIF IF (qi(i,k,j) < 1.E-8 .AND. CLDFRA_BL(i,k,j) > 0.001) THEN - qi(i,k,j)=qi(i,k,j) + QI_BL(i,k,j)*CLDFRA_BL(i,k,j) + qi(i,k,j)=qi(i,k,j) + QI_BL(i,k,j) ENDIF ENDDO ENDDO diff --git a/phys/module_sf_clm.F b/phys/module_sf_clm.F index 6d11ac7857..3a8c0d6006 100644 --- a/phys/module_sf_clm.F +++ b/phys/module_sf_clm.F @@ -59345,6 +59345,10 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & character*256 :: msg real :: mh_urb,stdh_urb,lp_urb,hgt_urb,frc_urb,lb_urb,check real, dimension(4) :: lf_urb +! Distributed aerodynamics parameters + real :: lf_urb_s + real :: z0_urb + real :: vegfrac logical, external :: wrf_dm_on_monitor @@ -60318,6 +60322,10 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & enddo frc_urb = FRC_URB2D(I,J) check = 0. +! Distributed aerodynamics + lf_urb_s = 0 + z0_urb = 0 + vegfrac = 0 ! ! Call urban @@ -60346,7 +60354,8 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & 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) + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB, & + lf_urb_s, z0_urb, vegfrac) !sw-- TS_URB2D(I,J) = TS_URB diff --git a/phys/module_sf_noahdrv.F b/phys/module_sf_noahdrv.F index 5c7df673a2..21bced2f46 100644 --- a/phys/module_sf_noahdrv.F +++ b/phys/module_sf_noahdrv.F @@ -110,6 +110,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & 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 + lf_urb2d_s, z0_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 @@ -595,6 +596,10 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: lp_urb REAL :: hgt_urb REAL, DIMENSION(4) :: lf_urb +! Distributed aerodynamics parameters + REAL :: lf_urb_s + REAL :: z0_urb + REAL :: vegfrac ! Variables for multi-layer UCM (Martilli et al. 2002) REAL, OPTIONAL, INTENT(IN ) :: GMT INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY @@ -655,6 +660,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & 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, jms:jme ), INTENT(IN) :: lf_urb2d_s + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: z0_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 @@ -1416,6 +1423,10 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & if (I.eq.73.and.J.eq.125)THEN check = 1 end if +! Distributed aerodynamics + lf_urb_s = lf_urb2d_s(I, J) + z0_urb = z0_urb2d(I, J) + vegfrac = vegfra(I, J) / 100 ! ! Call urban CALL cal_mon_day(julian,julyr,jmonth,jday) @@ -1439,7 +1450,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & 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) + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB, & + lf_urb_s, z0_urb, vegfrac) #if 0 IF(IPRINT) THEN @@ -2345,7 +2357,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & myj,frpcpn, & SH2O,SNOWH, & !H U_PHY,V_PHY, & !I - SNOALB,SHDMIN,SHDMAX, & !I + SNOALB,SHDMIN,SHDMAX,SHDAVG, & !I SNOTIME, & !? ACSNOM,ACSNOW, & !O SNOPCX, & !O @@ -2415,6 +2427,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & urban_map_zgrd, & !I multi-layer urban num_urban_hi, & !I multi-layer urban use_wudapt_lcz, & !I wudapt + slucm_distributed_drag, & !I slucm 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 @@ -2430,6 +2443,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & 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 + lf_urb2d_s, z0_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 @@ -2607,6 +2621,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & VEGFRA, & SHDMIN, & SHDMAX, & + SHDAVG, & SNOALB, & GSW, & SWDOWN, & !added 10 jan 2007 @@ -2881,7 +2896,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & 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 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D ! output variables urban --> lsm @@ -2911,6 +2926,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: lp_urb REAL :: hgt_urb REAL, DIMENSION(4) :: lf_urb +! Distributed aerodynamics parameters + REAL :: lf_urb_s + REAL :: z0_urb + REAL :: vegfrac ! Variables for multi-layer UCM (Martilli et al. 2002) REAL, OPTIONAL, INTENT(IN ) :: GMT INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY @@ -2928,6 +2947,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & INTEGER, INTENT(IN ) :: urban_map_zgrd INTEGER, INTENT(IN ) :: NUM_URBAN_HI INTEGER, INTENT(IN ) :: use_wudapt_lcz + LOGICAL, INTENT(IN ) :: slucm_distributed_drag 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 @@ -2971,6 +2991,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & 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, jms:jme ), INTENT(IN) :: lf_urb2d_s + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: z0_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 @@ -3717,46 +3739,32 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & 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 + + ! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) + ! this need to be changed in the mosaic danli + IF (slucm_distributed_drag) THEN + IF (IVGTYP(I, J) == ISURBAN) THEN + UTYPE_URB = 2 + END IF + ELSE 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 + 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 + END IF TA_URB = SFCTMP ! [K] QA_URB = Q2K ! [kg/kg] @@ -3871,6 +3879,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & if (I.eq.73.and.J.eq.125)THEN check = 1 end if + ! Distributed aerodynamics + lf_urb_s = lf_urb2d_s(I, J) + z0_urb = z0_urb2d(I, J) + vegfrac = vegfra(I, J) / 100. ! ! Call urban CALL cal_mon_day(julian,julyr,jmonth,jday) @@ -3894,8 +3906,9 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & 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) - + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB, & + lf_urb_s, z0_urb, vegfrac) + #if 0 IF(IPRINT) THEN @@ -3936,7 +3949,9 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! 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 (.not. slucm_distributed_drag) THEN + ZNT(I,J)= EXP(FRC_URB2D(I,J)*ALOG(ZNT_URB)+(1-FRC_URB2D(I,J))* ALOG(ZNT(I,J))) ! ADD BY DAN + END IF #if 0 IF(IPRINT)THEN @@ -4743,6 +4758,11 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & if (I.eq.73.and.J.eq.125)THEN check = 1 end if + ! Distributed aerodynamics + lf_urb_s = lf_urb2d_s(I, J) + z0_urb = z0_urb2d(I, J) + vegfrac = vegfra(I, J) / 100.0 + ! ! Call urban CALL cal_mon_day(julian,julyr,jmonth,jday) @@ -4766,8 +4786,9 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & 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) - + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB, & + lf_urb_s, z0_urb, vegfrac) + #if 0 IF(IPRINT) THEN diff --git a/phys/module_sf_pxlsm.F b/phys/module_sf_pxlsm.F index a4bbcb77bd..b2c0ce1aad 100755 --- a/phys/module_sf_pxlsm.F +++ b/phys/module_sf_pxlsm.F @@ -370,6 +370,8 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & LAND_USE_TYPE = 'MODIS' ELSE IF (NLCAT == 21) THEN LAND_USE_TYPE = 'MODIS' + ELSE IF (NLCAT == 61) THEN + LAND_USE_TYPE = 'MODIS' ELSE IF (NLCAT == 24) THEN LAND_USE_TYPE = 'USGS' ELSE IF (NLCAT == 28) THEN @@ -526,17 +528,19 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ! are converted to ice/snow for more reasonable treatment. IF( (XICE(I,J).GE.0.5) .OR. & (SST(I,J).LE.270.0.AND.XLAND(I,J).GE.1.50) ) THEN - XLAND(I,J) = 1.0 - IFLAND = 1.0 - ZNT(I,J) = 0.001 ! Ice - SMOIS(I,1,J) = 1.0 ! FWSAT - SMOIS(I,2,J) = 1.0 ! FWSAT - XICE(I,J) = 1.0 - ALBEDO(I,J) = 0.7 - SNOWC(I,J) = 1.0 - SNOW_FRA = 1.0 - VEGF_PX(I,J) = 0.0 - LAI(I,J) = 0.0 + XLAND(I,J) = 1.0 + IFLAND = 1.0 + ZNT(I,J) = 0.001 + SMOIS(I,1,J) = 1.0 + SMOIS(I,2,J) = 1.0 + XICE(I,J) = 1.0 + ALBEDO(I,J) = 0.7 + SNOWC(I,J) = 1.0 + SNOW_FRA = 1.0 + VEGF_PX(I,J) = 0.0 + LAI_PX(I,J) = 0.0 + LAI(I,J) = 0.0 + FCGSAT = 3.670 ENDIF !------------------------------------------------------------- @@ -652,10 +656,15 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & END DO ! Time internal PX time loop - IF (IFLAND .LT. 1.5) TSK(I,J) = TSLB(I,1,J) ! ATV 02/20: changed for compatibility with sst_skin = 1. - CANWAT(I,J)= WR * 1000. ! convert WR back to mm for CANWAT - RAW = RA(I,J) + 4.503 / USTAR - QSFC(I,J) = QFX(I,J) * RAW / DENS1 + QV1 + IF (IFLAND .GE. 1.5) THEN + TSK(I,J) = SST(I,J) ! Skin temp set to sea surface temperature for open water + GRDFLX(I,J) = 0.0 + ELSE + TSK(I,J) = TSLB(I,1,J) ! Skin temp set to 1 cm soil temperature in PX for now + ENDIF + CANWAT(I,J) = WR * 1000. ! convert WR back to mm for CANWAT + RAW = RA(I,J) + 4.503 / USTAR + QSFC(I,J) = QFX(I,J) * RAW / DENS1 + QV1 ENDDO ! END MIAN I LOOP ENDDO ! END MAIN J LOOP @@ -1175,6 +1184,7 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, SOLDN, GSW, & !in REAL :: RSOIL, LDRY, DP ! Soil model updates - JEP 12/14 REAL :: C1MAX,ZZA,ZZB,ZDEL,ZLY,ZA,ZB,ZY2 REAL :: Rinc, Hcan ! JEP 2020 + REAL :: CQ3BG,CQ3VW,CQ3VG,SIGG !... Parameters REAL :: ZOBS, GAMAH, BETAH, SIGF, BH, CT_SNOW, CT_IMPERV @@ -1287,7 +1297,7 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, SOLDN, GSW, & !in VEGFRC, ISNOW, ISTI, IFLAND, LAI, BETAP, & WG, W2, WR, & RSTMIN, WWLT, WFC, RSOIL, RINC, & - EG, ER, ETR, CQ4, RS, FASS) + EG, ER, ETR, CQ4, RS, FASS, SIGG) !-------------------------------------------------------------------- !-------------------------------------------------------------------- @@ -1330,18 +1340,17 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, SOLDN, GSW, & !in ! IMPERVIOUS weighting scheme -- Subtract highly accurate impervious fraction from cell ! remainder is split between ground and vegetation. CT is a weighted fractional average. ! Snow CT is then applied for final heat capacity - IMF = AMAX1(0.0,IMPERV/100.0) - VEGF = (1.0 - IMF) * VEGFRC - SOILF= (1.0 - IMF) * (1.0 - VEGFRC) - CT = 1./( IMF/CT_IMPERV + VEGF/CV + SOILF/CG) - CT = 1./(SNOW_FRA/CT_SNOW + (1-SNOW_FRA)/CT) - CAPG = 1.0/CT - + IMF = AMAX1(0.0,IMPERV/100.0) + VEGF = (1.0 - IMF) * VEGFRC + SOILF = (1.0 - IMF) * (1.0 - VEGFRC) + CT = 1./( IMF/CT_IMPERV + VEGF/CV + SOILF/CG) + CT = 1./(SNOW_FRA/CT_SNOW + (1-SNOW_FRA)/CT) + CAPG = 1.0/CT SOILFLX = 2.0 * PI * TAUINV * (TG - T2) GRDFLX = SOILFLX / CT ENDIF !----------------------------------------------------------------------------------------- - + !-------------------------------------------------------------------- !-- ASSIMILATION --- COMPUTE SOIL MOISTURE NUDGING FROM TA2 and RH2 !-------COMPUTE ASSIMILATION COEFFICIENTS FOR ALL I @@ -1374,7 +1383,10 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, SOLDN, GSW, & !in !-- Calculate the coefficients for implicit calculation of TG CQ1 = (1.0 - 0.622 * LV * CRANKP / (r_d * TG)) * QSS CQ2 = 0.622 * LV * QSS * CRANKP / (r_d * TG * TG) - CQ3 = DENS1 * (1.0 - VEGFRC) / (RAW + RSOIL) + CQ3BG = DENS1 * (1.0 - VEGFRC) / (RAW + RSOIL) + CQ3VW = DENS1 * VEGFRC*SIGG / RAW + CQ3VG = DENS1 * VEGFRC / (RAW + RSOIL + RINC) + CQ3 = CQ3BG + CQ3VW + CQ3VG COEFFNP1 = 1.0 + DTPBL * CRANKP * (4.0 * EMISSI * STBOLT * TG ** 3 & * CT + DENS1 * CPAIR / RAH * CPOT * CT + 2.0 * PI & * TAUINV ) + DTPBL * (CT * LV * CQ2 * (CQ3 + CQ4)) @@ -1497,8 +1509,8 @@ END SUBROUTINE surfpx SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in VEGFRC, ISNOW, ISTI, IFLAND, LAI, BETAP, & ! in WG, W2, WR, & ! in - RSTMIN, WWLT, WFC, RSOIL, RINC, & ! in !Soil model updates - JEP 12/14 - EG, ER, ETR, CQ4, RS, FASS) ! out + RSTMIN, WWLT, WFC, RSOIL, RINC, & ! in + EG, ER, ETR, CQ4, RS, FASS, SIGG ) ! out !------------------------------------------------------------------------- ! @@ -1535,9 +1547,10 @@ SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in !-- EG evaporation from ground (bare soil) !-- ER evaporation from canopy !-- ETR transpiration from vegetation -!-- CQ4 +!-- CQ4 CQ4 is used for the implicit calculation of TG in SURFACE !-- RS surface resistence !-- FASS parameter for soil moisture nudging +!-- SIGG near ground-first layer moisture difference for evap or dew (1) !------------------------------------------------------------------------- !------------------------------------------------------------------------- @@ -1554,12 +1567,12 @@ SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in REAL , INTENT(INOUT) :: BETAP, RSOIL REAL, INTENT(IN) :: WWLT, WFC, RINC - REAL , INTENT(OUT) :: EG, ER, ETR, CQ4, RS, FASS + REAL , INTENT(OUT) :: EG, ER, ETR, CQ4, RS, FASS, SIGG !... Local Variables !... Real - REAL :: WRMAX, DELTA, SIGG, RADL, RADF, W2AVAIL, W2MXAV + REAL :: WRMAX, DELTA, RADL, RADF, W2AVAIL, W2MXAV REAL :: FTOT, F1, F2, F3, F4 REAL :: FSHELT, GS, GA, FX REAL :: PAR, F1MAX diff --git a/phys/module_sf_pxlsm_data.F b/phys/module_sf_pxlsm_data.F index e9def75186..4ed64508ad 100644 --- a/phys/module_sf_pxlsm_data.F +++ b/phys/module_sf_pxlsm_data.F @@ -31,10 +31,13 @@ MODULE module_sf_pxlsm_data ! 18 175. 30. 70. 50. 3.4 2.0 0.80 15. 45. wooded tundra ! 19 120. 15. 40. 20. 2.4 1.0 0.40 15. 50. mixed tundra ! 20 100. 10. 20. 5. 1.4 0.1 .015 25. 75. barren tundra +! 21 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. inland lakes +! 22-50 Unassigned +! 51-61 150. 80. 5. 5. 2.0 0.5 0.04 11. 46. Urban LCZ 1-10 * Static urban settings * !------------------------------------------------------------------------------------ !**************************************************************************************** !**************************************************************************************** - REAL, DIMENSION(21), TARGET :: RSMIN_MODIS, Z00_MODIS, & + REAL, DIMENSION(61), TARGET :: RSMIN_MODIS, Z00_MODIS, & VEG0_MODIS, VEGMN0_MODIS, & LAI0_MODIS, LAIMN0_MODIS, & SNUP0_MODIS, ALBF_MODIS, & @@ -44,55 +47,127 @@ MODULE module_sf_pxlsm_data / 175.0, 120.0, 175.0, 200.0, 200.0, & 200.0, 200.0, 150.0, 120.0, 100.0, & 200.0, 70.0, 150.0, 100.0, 9999.0, & - 100.0, 9999.0, 175.0, 120.0, 100.0, 9999.0 / + 100.0, 9999.0, 175.0, 120.0, 100.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 150.0, 150.0, 150.0, 150.0, 150.0, & + 150.0, 150.0, 150.0, 150.0, 150.0, 150.0 / DATA Z00_MODIS & / 100.0, 90.0, 100.0, 100.0, 100.0, & 15.0, 15.0, 25.0, 15.0, 7.0, & 20.0, 10.0, 80.0, 30.0, 1.2, & - 5.0, 0.1, 30.0, 15.0, 10.0, 0.1 / + 5.0, 0.1, 30.0, 15.0, 10.0, & + 0.1, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 80.0, 80.0, 80.0, 80.0, 80.0, & + 80.0, 80.0, 80.0, 80.0, 80.0, 80.0 / DATA VEG0_MODIS & / 93.0, 92.0, 60.0, 91.0, 92.0, & 40.0, 20.0, 70.0, 70.0, 50.0, & 65.0, 90.0, 5.0, 80.0, 0.1, & - 0.5, 0.0, 70.0, 40.0, 20.0, 0.0 / + 0.5, 0.0, 70.0, 40.0, 20.0, & + 0.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 5.0, 5.0, 5.0, 5.0, 5.0, & + 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 / DATA VEGMN0_MODIS & / 93.0, 92.0, 60.0, 91.0, 92.0, & 20.0, 10.0, 60.0, 40.0, 20.0, & 35.0, 20.0, 5.0, 40.0, 0.1, & - 0.5, 0.0, 50.0, 20.0, 5.0, 0.0 / + 0.5, 0.0, 50.0, 20.0, 5.0, & + 0.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 5.0, 5.0, 5.0, 5.0, 5.0, & + 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 / DATA LAI0_MODIS & / 5.5, 6.0, 3.0, 6.0, 5.5, & 1.5, 1.5, 2.3, 1.5, 1.5, & 2.5, 3.5, 2.0, 3.5, 0.1, & - 0.2, 0.0, 3.4, 2.4, 1.4, 0.0 / + 0.2, 0.0, 3.4, 2.4, 1.4, & + 0.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 2.0, 2.0, 2.0, 2.0, 2.0, & + 2.0, 2.0, 2.0, 2.0, 2.0, 2.0 / DATA LAIMN0_MODIS & / 3.5, 3.5, 1.5, 2.0, 2.5, & 1.0, 1.3, 2.0, 1.5, 1.5, & 2.0, 1.5, 1.5, 1.5, 0.1, & - 0.1, 0.0, 2.0, 1.0, 0.1, 0.0 / + 0.1, 0.0, 2.0, 1.0, 0.1, & + 0.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 1.5, 1.5, 1.5, 1.5, 1.5, & + 1.5, 1.5, 1.5, 1.5, 1.5, 1.5 / DATA SNUP0_MODIS & - / 0.08, 0.08, 0.08, 0.08, 0.08, & - 0.03, 0.035, 0.03, 0.04, 0.04, & - 0.08, 0.04, 0.04, 0.04, 0.02, & - 0.02, 0.01, 0.80, 0.40, 0.015, 0.01 / + / 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.03, 0.035, 0.03, 0.04, 0.04, & + 0.08, 0.04, 0.04, 0.04, 0.02, & + 0.02, 0.01, 0.80, 0.40, 0.015, & + 0.01, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 0.04, 0.04, 0.04, 0.04, 0.04, & + 0.04, 0.04, 0.04, 0.04, 0.04, 0.04 / DATA ALBF_MODIS & / 12.0, 12.0, 14.0, 16.0, 13.0, & 22.0, 20.0, 22.0, 20.0, 19.0, & 17.0, 18.0, 11.0, 18.0, 60.0, & - 25.0, 8.0, 15.0, 15.0, 25.0, 8.0 / + 25.0, 8.0, 15.0, 15.0, 25.0, & + 8.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 11.0, 11.0, 11.0, 11.0, 11.0, & + 11.0, 11.0, 11.0, 11.0, 11.0, 11.0 / DATA SNOALB_MODIS & / 30.0, 30.0, 30.0, 40.0, 35.0, & 50.0, 60.0, 50.0, 50.0, 70.0, & 50.0, 66.0, 46.0, 68.0, 82.0, & - 75.0, 8.0, 45.0, 55.0, 75.0, 8.0 / + 75.0, 8.0, 45.0, 55.0, 75.0, & + 8.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 9999.0, 9999.0, 9999.0, 9999.0, 9999.0, & + 46.0, 46.0, 46.0, 46.0, 46.0, & + 46.0, 46.0, 46.0, 46.0, 46.0, 46.0 / !**************************************************************************************** !**************************************************************************************** diff --git a/phys/module_sf_ruclsm.F b/phys/module_sf_ruclsm.F index caf02f33e4..16cb15a360 100644 --- a/phys/module_sf_ruclsm.F +++ b/phys/module_sf_ruclsm.F @@ -1,150 +1,184 @@ -#define LSMRUC_DBG_LVL 3000 -!WRF:MODEL_LAYER:PHYSICS +#define lsmruc_dbg_lvl 3000 +!wrf:model_layer:physics ! -MODULE module_sf_ruclsm +module module_sf_ruclsm -! Notes for perturbations of soil properties (Judith Berner) -! Perturbations are applied in subroutine soilprob to array hydro; -! soilprop is called from subroutine SFCTMP which is called from subroutine LSMRUC; -! subroutine LSMRUC had two new 3D fields: pattern_spp_lsm (in) and field_sf(inout); +! notes for perturbations of soil properties (judith berner) +! perturbations are applied in subroutine soilprob to array hydro; +! soilprop is called from subroutine sfctmp which is called from subroutine lsmruc; +! subroutine lsmruc had two new 3d fields: pattern_spp_lsm (in) and field_sf(inout); ! their vertical dimension is number of atmospheric levels (kms:kme) - (suboptimal, but easiest hack) ! field_sf is used to pass perturbed fields of hydrop up to model (and output) driver; -! in argument list to SFCTMP the arrays are passed as pattern_spp_lsm(i,1:nzs,j), and exist henceforth as +! in argument list to sfctmp the arrays are passed as pattern_spp_lsm(i,1:nzs,j), and exist henceforth as ! column arrays; -! in the subroutines below SFCTMP (SNOW and SNOWSOIL) the fields are called rstochcol,fieldcol_sf +! in the subroutines below sfctmp (snow and snowsoil) the fields are called rstochcol,fieldcol_sf ! to reflect their dimension rstochcol (1:nzs) - USE module_model_constants - USE module_wrf_error - -! VEGETATION PARAMETERS - INTEGER :: LUCATS , BARE, NATURAL, CROP, URBAN - integer, PARAMETER :: NLUS=50 - CHARACTER*8 LUTYPE - INTEGER, DIMENSION(1:NLUS) :: IFORTBL - real, dimension(1:NLUS) :: SNUPTBL, RSTBL, RGLTBL, HSTBL, LAITBL, & - ALBTBL, Z0TBL, LEMITBL, PCTBL, SHDTBL, MAXALB - REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA -! SOIL PARAMETERS - INTEGER :: SLCATS - INTEGER, PARAMETER :: NSLTYPE=30 - CHARACTER*8 SLTYPE - REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,HC, & - MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ - -! LSM GENERAL PARAMETERS - INTEGER :: SLPCATS - INTEGER, PARAMETER :: NSLOPE=30 - REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA - REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & - REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & - CZIL_DATA - - CHARACTER*256 :: err_message - - -CONTAINS + use module_model_constants + use module_wrf_error + +! vegetation parameters + integer :: lucats , bare, natural, crop, urban + integer, parameter :: nlus=50 + character*8 lutype + integer, dimension(1:nlus) :: ifortbl + real, dimension(1:nlus) :: snuptbl, rstbl, rgltbl, hstbl, laitbl, & + albtbl, z0tbl, lemitbl, pctbl, shdtbl, maxalb + real :: topt_data,cmcmax_data,cfactr_data,rsmax_data +! soil parameters + integer :: slcats + integer, parameter :: nsltype=30 + character*8 sltype + real, dimension (1:nsltype) :: bb,drysmc,hc, & + maxsmc, refsmc,satpsi,satdk,satdw, wltsmc,qtz + +! lsm general parameters + integer :: slpcats + integer, parameter :: nslope=30 + real, dimension (1:nslope) :: slope_data + real :: sbeta_data,fxexp_data,csoil_data,salp_data,refdk_data, & + refkdt_data,frzk_data,zbot_data, smlow_data,smhigh_data, & + czil_data + + character*256 :: err_message + + !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 + ! integer, parameter :: isncond_opt = 1 + ! + integer, parameter :: isncond_opt=2 + + !-- Snow fraction options + !-- option 1: original formulation using threshold snow depth to compute snow fraction + !integer, parameter :: isncovr_opt = 1 (default) + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. + !integer, parameter :: isncovr_opt = 2 + !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with + ! vegetation-dependent parameters from Noah MP (personal communication with + ! Mike Barlage) + !integer, parameter :: isncovr_opt = 3 + !-- Values of parameters are scale-dependent, have to be tuned for a given application + !-- Tables below are for 21-class MODI-RUC (MODIFIED_IGBP_MODIS_NOAH_15s is used in HRRR and RRFS) + !-- for 3-km RRFS application + real, dimension(30), parameter :: sncovfac = & + & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & + & 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, & + & 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000 /) + real, dimension(30), parameter :: mfsno = & + & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & + & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & + & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + + !-- + integer, parameter :: isncovr_opt=2 + !-- + +contains !----------------------------------------------------------------- - SUBROUTINE LSMRUC(spp_lsm, & + subroutine lsmruc(spp_lsm, & #if (EM_CORE==1) pattern_spp_lsm,field_sf, & #endif - DT,KTAU,NSL, & + dt,ktau,nsl, & #if (EM_CORE==1) lakemodel,lakemask, & graupelncv,snowncv,rainncv, & #endif - ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & + zs,rainbl,snow,snowh,snowc,frzfrac,frpcpn, & rhosnf,precipfr, & ! pass it out to module_diagnostics - Z3D,P8W,T3D,QV3D,QC3D,RHO3D, & !p8W in [PA] - GLW,GSW,EMISS,CHKLOWQ, CHS, & - FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & - Z0,SNOALB,ALBBCK,LAI, & !new + z3d,p8w,t3d,qv3d,qc3d,rho3d, & !p8w in [pa] + glw,gsw,emiss,chklowq, chs, & + flqc,flhc,mavail,canwat,vegfra,alb,znt, & + z0,snoalb,albbck,lai, & !new mminlu, landusef, nlcat, mosaic_lu, & mosaic_soil, soilctop, nscat, & !new - QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & - TBOT,IVGTYP,ISLTYP,XLAND, & - ISWATER,ISICE,XICE,XICE_THRESHOLD, & - CP,ROVCP,G0,LV,STBOLT, & - SOILMOIS,SH2O,SMAVAIL,SMMAX, & - TSO,SOILT,HFX,QFX,LH, & - SFCRUNOFF,UDRUNOFF,ACRUNOFF,SFCEXC, & - SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & - SMFR3D,KEEPFR3DFLAG, & - myjpbl,shdmin,shdmax,rdlai2d, & + qsfc,qsg,qvg,qcg,dew,soilt1,tsnav, & + tbot,ivgtyp,isltyp,xland, & + iswater,isice,xice,xice_threshold, & + cp,rovcp,g0,lv,stbolt, & + soilmois,sh2o,smavail,smmax, & + tso,soilt,hfx,qfx,lh, & + sfcrunoff,udrunoff,acrunoff,sfcexc, & + sfcevp,grdflx,snowfallac,acsnow,snom, & + smfr3d,keepfr3dflag, & + myj,shdmin,shdmax,rdlai2d, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !----------------------------------------------------------------- - IMPLICIT NONE + implicit none !----------------------------------------------------------------- ! -! The RUC LSM model is described in: +! the ruc lsm model is described in: ! Smirnova, T.G., J.M. Brown, and S.G. Benjamin, 1997: -! Performance of different soil model configurations in simulating +! performance of different soil model configurations in simulating ! ground surface temperature and surface fluxes. -! Mon. Wea. Rev. 125, 1870-1884. -! Smirnova, T.G., J.M. Brown, and D. Kim, 2000: Parameterization of -! cold-season processes in the MAPS land-surface scheme. -! J. Geophys. Res. 105, 4077-4086. +! mon. wea. rev. 125, 1870-1884. +! Smirnova, T.G., J.M. Brown, and D. Kim, 2000: parameterization of +! cold-season processes in the maps land-surface scheme. +! j. geophys. res. 105, 4077-4086. !----------------------------------------------------------------- -!-- DT time step (second) +!-- dt time step (second) ! ktau - number of time step -! NSL - number of soil layers -! NZS - number of levels in soil -! ZS - depth of soil levels (m) -!-- RAINBL - accumulated rain in [mm] between the PBL calls -!-- RAINNCV one time step grid scale precipitation (mm/step) -! SNOW - snow water equivalent [mm] -! FRAZFRAC - fraction of frozen precipitation -!-- PRECIPFR (mm) - time step frozen precipitation -!-- SNOWC flag indicating snow coverage (1 for snow cover) -!-- Z3D heights (m) -!-- P8W 3D pressure (Pa) -!-- T3D temperature (K) -!-- QV3D 3D water vapor mixing ratio (Kg/Kg) -! QC3D - 3D cloud water mixing ratio (Kg/Kg) -! RHO3D - 3D air density (kg/m^3) -!-- GLW downward long wave flux at ground surface (W/m^2) -!-- GSW absorbed short wave flux at ground surface (W/m^2) -!-- EMISS surface emissivity (between 0 and 1) -! FLQC - surface exchange coefficient for moisture (kg/m^2/s) -! FLHC - surface exchange coefficient for heat [W/m^2/s/degreeK] -! SFCEXC - surface exchange coefficient for heat [m/s] -! CANWAT - CANOPY MOISTURE CONTENT (mm) -! VEGFRA - vegetation fraction (between 0 and 100) -! ALB - surface albedo (between 0 and 1) -! SNOALB - maximum snow albedo (between 0 and 1) -! ALBBCK - snow-free albedo (between 0 and 1) -! ZNT - roughness length [m] -!-- TBOT soil temperature at lower boundary (K) -! IVGTYP - USGS vegetation type (24 classes) -! ISLTYP - STASGO soil type (16 classes) -!-- XLAND land mask (1 for land, 2 for water) -!-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- G0 acceleration due to gravity (m/s^2) -!-- LV latent heat of melting (J/kg) -!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) -! SOILMOIS - soil moisture content (volumetric fraction) -! TSO - soil temp (K) -!-- SOILT surface temperature (K) -!-- HFX upward heat flux at the surface (W/m^2) -!-- QFX upward moisture flux at the surface (kg/m^2/s) -!-- LH upward latent heat flux (W/m^2) -! SFCRUNOFF - ground surface runoff [mm] -! UDRUNOFF - underground runoff [mm] -! ACRUNOFF - run-total surface runoff [mm] -! SFCEVP - total evaporation in [kg/m^2] -! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! SNOWFALLAC - run-total snowfall accumulation [m] -! ACSNOW - run-toral SWE of snowfall [mm] -!-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). -!-- used only in MYJPBL. -!-- tice - sea ice temperture (C) +! nsl - number of soil layers +! nzs - number of levels in soil +! zs - depth of soil levels (m) +!-- rainbl - accumulated rain in [mm] between the pbl calls +!-- rainncv one time step grid scale precipitation (mm/step) +! snow - snow water equivalent [mm] +! frazfrac - fraction of frozen precipitation +!-- precipfr (mm) - time step frozen precipitation +!-- snowc flag indicating snow coverage (1 for snow cover) +!-- z3d heights (m) +!-- p8w 3d pressure (pa) +!-- t3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +! qc3d - 3d cloud water mixing ratio (kg/kg) +! rho3d - 3d air density (kg/m^3) +!-- glw downward long wave flux at ground surface (w/m^2) +!-- gsw absorbed short wave flux at ground surface (w/m^2) +!-- emiss surface emissivity (between 0 and 1) +! flqc - surface exchange coefficient for moisture (kg/m^2/s) +! flhc - surface exchange coefficient for heat [w/m^2/s/degreek] +! sfcexc - surface exchange coefficient for heat [m/s] +! canwat - canopy moisture content (mm) +! vegfra - vegetation fraction (between 0 and 100) +! alb - surface albedo (between 0 and 1) +! snoalb - maximum snow albedo (between 0 and 1) +! albbck - snow-free albedo (between 0 and 1) +! znt - roughness length [m] +!-- tbot soil temperature at lower boundary (k) +! ivgtyp - usgs vegetation type (24 classes) +! isltyp - stasgo soil type (16 classes) +!-- xland land mask (1 for land, 2 for water) +!-- cp heat capacity at constant pressure for dry air (j/kg/k) +!-- g0 acceleration due to gravity (m/s^2) +!-- lv latent heat of melting (j/kg) +!-- stbolt stefan-boltzmann constant (w/m^2/k^4) +! soilmois - soil moisture content (volumetric fraction) +! tso - soil temp (k) +!-- soilt surface temperature (k) +!-- hfx upward heat flux at the surface (w/m^2) +!-- qfx upward moisture flux at the surface (kg/m^2/s) +!-- lh upward latent heat flux (w/m^2) +! sfcrunoff - ground surface runoff [mm] +! udrunoff - underground runoff [mm] +! acrunoff - run-total surface runoff [mm] +! sfcevp - total evaporation in [kg/m^2] +! grdflx - soil heat flux (w/m^2: negative, if downward from surface) +! snowfallac - run-total snowfall accumulation [m] +! acsnow - run-toral swe of snowfall [mm] +!-- chklowq - is either 0 or 1 (so far set equal to 1). +!-- used only in myjpbl. +!-- tice - sea ice temperture (c) !-- rhosice - sea ice density (kg m^-3) -!-- capice - sea ice volumetric heat capacity (J/m^3/K) +!-- capice - sea ice volumetric heat capacity (j/m^3/k) !-- thdifice - sea ice thermal diffusivity (m^2/s) !-- !-- ims start index for i in memory @@ -154,147 +188,146 @@ SUBROUTINE LSMRUC(spp_lsm, & !-- kms start index for k in memory !-- kme end index for k in memory !------------------------------------------------------------------------- -! INTEGER, PARAMETER :: nzss=5 -! INTEGER, PARAMETER :: nddzs=2*(nzss-2) +! integer, parameter :: nzss=5 +! integer, parameter :: nddzs=2*(nzss-2) - INTEGER, PARAMETER :: nvegclas=24+3 + integer, parameter :: nvegclas=24+3 - REAL, INTENT(IN ) :: DT - LOGICAL, INTENT(IN ) :: myjpbl,frpcpn - INTEGER, INTENT(IN ) :: spp_lsm - INTEGER, INTENT(IN ) :: NLCAT, NSCAT, mosaic_lu, mosaic_soil - INTEGER, INTENT(IN ) :: ktau, nsl, isice, iswater, & + real, intent(in ) :: dt + logical, intent(in ) :: myj,frpcpn + integer, intent(in ) :: spp_lsm + integer, intent(in ) :: nlcat, nscat, mosaic_lu, mosaic_soil + integer, intent(in ) :: ktau, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & ids,ide, jds,jde, kds,kde, & its,ite, jts,jte, kts,kte #if (EM_CORE==1) - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL:: pattern_spp_lsm - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL:: field_sf + real, dimension( ims:ime, kms:kme, jms:jme ),optional:: pattern_spp_lsm + real, dimension( ims:ime, kms:kme, jms:jme ),optional:: field_sf #endif - REAL, DIMENSION( ims:ime, 1 :nsl, jms:jme ) :: field_sf_loc + real, dimension( ims:ime, 1 :nsl, jms:jme ) :: field_sf_loc - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: QV3D, & - QC3D, & + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(in ) :: qv3d, & + qc3d, & p8w, & - rho3D, & - T3D, & - z3D - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: RAINBL, & - GLW, & - GSW, & - ALBBCK, & - FLHC, & - FLQC, & - CHS , & - XICE, & - XLAND, & -! ALBBCK, & -! VEGFRA, & - TBOT + rho3d, & + t3d, & + z3d + + real, dimension( ims:ime , jms:jme ), & + intent(in ) :: rainbl, & + glw, & + gsw, & + albbck, & + flhc, & + flqc, & + chs , & + xice, & + xland, & +! albbck, & + tbot !beka - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT ) :: VEGFRA + real, dimension( ims:ime , jms:jme ), & + intent(inout ) :: vegfra #if (EM_CORE==1) - REAL, OPTIONAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: GRAUPELNCV, & - SNOWNCV, & - RAINNCV - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: lakemask - INTEGER, INTENT(IN ) :: LakeModel + real, optional, dimension( ims:ime , jms:jme ), & + intent(in ) :: graupelncv, & + snowncv, & + rainncv + real, dimension( ims:ime , jms:jme ), & + intent(in ) :: lakemask + integer, intent(in ) :: lakemodel #endif - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN - LOGICAL, intent(in) :: rdlai2d - - REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: & - SNOW, & - SNOWH, & - SNOWC, & - CANWAT, & ! new - SNOALB, & - ALB, & - EMISS, & - LAI, & - MAVAIL, & - SFCEXC, & - Z0 , & - ZNT - - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: & - FRZFRAC - - INTEGER, DIMENSION( ims:ime , jms:jme ), & - INTENT(IN ) :: IVGTYP, & - ISLTYP - CHARACTER(LEN=*), INTENT(IN ) :: MMINLU - REAL, DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF - REAL, DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - - REAL, INTENT(IN ) :: CP,ROVCP,G0,LV,STBOLT,XICE_threshold + real, dimension( ims:ime , jms:jme ), intent(in ):: shdmax + real, dimension( ims:ime , jms:jme ), intent(in ):: shdmin + logical, intent(in) :: rdlai2d + + real, dimension( 1:nsl), intent(in ) :: zs + + real, dimension( ims:ime , jms:jme ), & + intent(inout) :: & + snow, & + snowh, & + snowc, & + canwat, & ! new + snoalb, & + alb, & + emiss, & + lai, & + mavail, & + sfcexc, & + z0 , & + znt + + real, dimension( ims:ime , jms:jme ), & + intent(in ) :: & + frzfrac + + integer, dimension( ims:ime , jms:jme ), & + intent(in ) :: ivgtyp, & + isltyp + character(len=*), intent(in ) :: mminlu + real, dimension( ims:ime , 1:nlcat, jms:jme ), intent(in):: landusef + real, dimension( ims:ime , 1:nscat, jms:jme ), intent(in):: soilctop + + real, intent(in ) :: cp,rovcp,g0,lv,stbolt,xice_threshold - REAL, DIMENSION( ims:ime , 1:nsl, jms:jme ) , & - INTENT(INOUT) :: SOILMOIS,SH2O,TSO - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: SOILT, & - HFX, & - QFX, & - LH, & - SFCEVP, & - SFCRUNOFF, & - UDRUNOFF, & - ACRUNOFF, & - GRDFLX, & - ACSNOW, & - SNOM, & - QVG, & - QCG, & - DEW, & - QSFC, & - QSG, & - CHKLOWQ, & - SOILT1, & - TSNAV - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: SMAVAIL, & - SMMAX - - REAL, DIMENSION( its:ite, jts:jte ) :: & - PC, & - RUNOFF1, & - RUNOFF2, & - EMISSL, & - ZNTL, & - LMAVAIL, & - SMELT, & - SNOH, & - SNFLX, & - EDIR, & - EC, & - ETT, & - SUBLIM, & + real, dimension( ims:ime , 1:nsl, jms:jme ) , & + intent(inout) :: soilmois,sh2o,tso + + real, dimension( ims:ime, jms:jme ) , & + intent(inout) :: soilt, & + hfx, & + qfx, & + lh, & + sfcevp, & + sfcrunoff, & + udrunoff, & + acrunoff, & + grdflx, & + acsnow, & + snom, & + qvg, & + qcg, & + dew, & + qsfc, & + qsg, & + chklowq, & + soilt1, & + tsnav + + real, dimension( ims:ime, jms:jme ) , & + intent(inout) :: smavail, & + smmax + + real, dimension( its:ite, jts:jte ) :: & + pc, & + runoff1, & + runoff2, & + emissl, & + zntl, & + lmavail, & + smelt, & + snoh, & + snflx, & + edir, & + ec, & + ett, & + sublim, & sflx, & smf, & - EVAPL, & - PRCPL, & - SEAICE, & - INFILTR -! Energy and water budget variables: - REAL, DIMENSION( its:ite, jts:jte ) :: & + evapl, & + prcpl, & + seaice, & + infiltr +! energy and water budget variables: + real, dimension( its:ite, jts:jte ) :: & budget, & acbudget, & waterbudget, & @@ -304,114 +337,114 @@ SUBROUTINE LSMRUC(spp_lsm, & canwatold - REAL, DIMENSION( ims:ime, 1:nsl, jms:jme) & - :: KEEPFR3DFLAG, & - SMFR3D + real, dimension( ims:ime, 1:nsl, jms:jme) & + :: keepfr3dflag, & + smfr3d - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & - RHOSNF, & !RHO of snowfall - PRECIPFR, & ! time-step frozen precip - SNOWFALLAC + real, dimension( ims:ime, jms:jme ), intent(out) :: & + rhosnf, & !rho of snowfall + precipfr, & ! time-step frozen precip + snowfallac !--- soil/snow properties - REAL & - :: RHOCS, & - RHONEWSN, & - RHOSN, & - RHOSNFALL, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QMIN, & - QWRTZ, & - REF, & - WILT, & - CANWATR, & - SNOWFRAC, & - SNHEI, & - SNWE - - REAL :: CN, & - SAT,CW, & - C1SN, & - C2SN, & - KQWRTZ, & - KICE, & - KWT - - - REAL, DIMENSION(1:NSL) :: ZSMAIN, & - ZSHALF, & - DTDZS2 - - REAL, DIMENSION(1:2*(nsl-2)) :: DTDZS - - REAL, DIMENSION(1:5001) :: TBQ - - - REAL, DIMENSION( 1:nsl ) :: SOILM1D, & - TSO1D, & - SOILICE, & - SOILIQW, & - SMFRKEEP - - REAL, DIMENSION( 1:nsl ) :: KEEPFR + real & + :: rhocs, & + rhonewsn, & + rhosn, & + rhosnfall, & + bclh, & + dqm, & + ksat, & + psis, & + qmin, & + qwrtz, & + ref, & + wilt, & + canwatr, & + snowfrac, & + snhei, & + snwe + + real :: cn, & + sat,cw, & + c1sn, & + c2sn, & + kqwrtz, & + kice, & + kwt + + + real, dimension(1:nsl) :: zsmain, & + zshalf, & + dtdzs2 + + real, dimension(1:2*(nsl-2)) :: dtdzs + + real, dimension(1:5001) :: tbq + + + real, dimension( 1:nsl ) :: soilm1d, & + tso1d, & + soilice, & + soiliqw, & + smfrkeep + + real, dimension( 1:nsl ) :: keepfr - REAL, DIMENSION( 1:nlcat ) :: lufrac - REAL, DIMENSION( 1:nscat ) :: soilfrac + real, dimension( 1:nlcat ) :: lufrac + real, dimension( 1:nscat ) :: soilfrac - REAL :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real :: rsm, & + snweprint, & + snheiprint - REAL :: PRCPMS, & - NEWSNMS, & + real :: prcpms, & + newsnms, & prcpncliq, & prcpncfr, & prcpculiq, & prcpcufr, & - PATM, & - PATMB, & - TABS, & - QVATM, & - QCATM, & - Q2SAT, & - CONFLX, & - RHO, & - QKMS, & - TKMS, & + patm, & + patmb, & + tabs, & + qvatm, & + qcatm, & + q2sat, & + conflx, & + rho, & + qkms, & + tkms, & snowrat, & grauprat, & graupamt, & icerat, & curat, & - INFILTRP - REAL :: cq,r61,r273,arp,brp,x,evs,eis - REAL :: cropsm + infiltrp + real :: cq,r61,r273,arp,brp,x,evs,eis + real :: cropfr, cropsm, newsm, factor - REAL :: meltfactor, ac,as, wb - INTEGER :: NROOT - INTEGER :: ILAND,ISOIL,IFOREST + real :: meltfactor, ac,as, wb + integer :: nroot + integer :: iland,isoil,iforest - INTEGER :: I,J,K,NZS,NZS1,NDDZS - INTEGER :: k1,l,k2,kp,km - CHARACTER (LEN=132) :: message + integer :: i,j,k,nzs,nzs1,nddzs + integer :: k1,l,k2,kp,km + character (len=132) :: message - REAL,DIMENSION(ims:ime,1:nsl,jms:jme) :: rstoch + real,dimension(ims:ime,1:nsl,jms:jme) :: rstoch !beka - REAL,DIMENSION(ims:ime,jms:jme)::EMISSO,VEGFRAO,ALBO,SNOALBO - REAL,DIMENSION(its:ite,jts:jte)::EMISSLO + real,dimension(ims:ime,jms:jme)::emisso,vegfrao,albo,snoalbo + real,dimension(its:ite,jts:jte)::emisslo !----------------------------------------------------------------- - NZS=NSL - NDDZS=2*(nzs-2) + nzs=nsl + nddzs=2*(nzs-2) rstoch=0.0 field_sf_loc=0.0 !beka added #if (EM_CORE==1) if (spp_lsm==1) then - do J=jts,jte + do j=jts,jte do i=its,ite do k=1,nsl rstoch(i,k,j) = pattern_spp_lsm(i,k,j) @@ -421,85 +454,85 @@ SUBROUTINE LSMRUC(spp_lsm, & enddo endif #endif -!---- table TBQ is for resolution of balance equation in VILKA - CQ=173.15-.05 - R273=1./273.15 - R61=6.1153*0.62198 - ARP=77455.*41.9/461.525 - BRP=64.*41.9/461.525 - - DO K=1,5001 - CQ=CQ+.05 -! TBQ(K)=R61*EXP(ARP*(R273-1./CQ)-BRP*LOG(CQ*R273)) - EVS=EXP(17.67*(CQ-273.15)/(CQ-29.65)) - EIS=EXP(22.514-6.15E3/CQ) - if(CQ.ge.273.15) then +!---- table tbq is for resolution of balance equation in vilka + cq=173.15-.05 + r273=1./273.15 + r61=6.1153*0.62198 + arp=77455.*41.9/461.525 + brp=64.*41.9/461.525 + + do k=1,5001 + cq=cq+.05 + evs=exp(17.67*(cq-273.15)/(cq-29.65)) + eis=exp(22.514-6.15e3/cq) + if(cq.ge.273.15) then ! tbq is in mb - tbq(k) = R61*evs + tbq(k) = r61*evs else - tbq(k) = R61*eis + tbq(k) = r61*eis endif - END DO - -!--- Initialize soil/vegetation parameters -!--- This is temporary until SI is added to mass coordinate ---!!!!! + end do +!--- initialize soil/vegetation parameters #if ( NMM_CORE == 1 ) if(ktau+1.eq.1) then #else if(ktau.eq.1) then #endif - DO J=jts,jte - DO i=its,ite + do j=jts,jte + do i=its,ite do k=1,nsl keepfr3dflag(i,k,j)=0. enddo -!--- initializing snow fraction, thereshold = 32 mm of snow water -! or ~100 mm of snow height -! - snowc(i,j) = min(1.,snow(i,j)/32.) - if(snow(i,j).le.32.) soilt1(i,j)=tso(i,1,j) -!--- initializing inside snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snow(i,j).gt.32.) THEN +!--- initializing snow fraction, thereshold = 32 mm of snow water or ~100 mm of snow height + if((soilt1(i,j) .lt. 170.) .or. (soilt1(i,j) .gt.400.)) then + if(snowc(i,j).gt.0.) then soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j)) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - WRITE ( message , FMT='(A,F8.3,2I6)' ) & - 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j - CALL wrf_debug ( 0 , message ) - ENDIF - ELSE + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + write ( message , fmt='(a,f8.3,2i6)' ) & + 'temperature inside snow is initialized in ruclsm ', soilt1(i,j),i,j + call wrf_debug ( 0 , message ) + endif + else soilt1(i,j) = tso(i,1,j) - ENDIF - ENDIF + endif ! snowc + endif ! soilt1 + !-- temperature inside snow is initialized tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15 - qcg (i,j) =0. - patmb=P8w(i,kms,j)*1.e-2 - QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - IF((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) THEN - qvg (i,j) = QSG(i,j)*mavail(i,j) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - WRITE ( message , FMT='(A,3F8.3,2I6)' ) & - 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,j - CALL wrf_debug ( 0 , message ) - ENDIF - ENDIF + patmb=p8w(i,kms,j)*1.e-2 + qsg (i,j) = qsn(soilt(i,j),tbq)/patmb + if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + qcg (i,j) = qc3d(i,1,j) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + write ( message , fmt='(a,3f8.3,2i6)' ) & + 'qvg is initialized in ruclsm ', qvg(i,j),mavail(i,j),qsg(i,j),i,j + endif + endif ! qcg + + if((qvg(i,j) .le. 0.) .or. (qvg(i,j) .gt.0.1)) then + qvg (i,j) = qsg(i,j)*mavail(i,j) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + write ( message , fmt='(a,3f8.3,2i6)' ) & + 'qvg is initialized in ruclsm ', qvg(i,j),mavail(i,j),qsg(i,j),i,j + call wrf_debug ( 0 , message ) + endif + endif qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - SMELT(i,j) = 0. - SNOM (i,j) = 0. - SNOWFALLAC(i,j) = 0. - PRECIPFR(i,j) = 0. - RHOSNF(i,j) = -1.e3 ! non-zero flag - SNFLX(i,j) = 0. - DEW (i,j) = 0. - PC (i,j) = 0. + smelt(i,j) = 0. + snom (i,j) = 0. + snowfallac(i,j) = 0. + precipfr(i,j) = 0. + rhosnf(i,j) = -1.e3 ! non-zero flag + snflx(i,j) = 0. + dew (i,j) = 0. + pc (i,j) = 0. zntl (i,j) = 0. - RUNOFF1(i,j) = 0. - RUNOFF2(i,j) = 0. - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - ACRUNOFF(i,j) = 0. + runoff1(i,j) = 0. + runoff2(i,j) = 0. + sfcrunoff(i,j) = 0. + udrunoff(i,j) = 0. + acrunoff(i,j) = 0. emissl (i,j) = 0. budget(i,j) = 0. acbudget(i,j) = 0. @@ -507,10 +540,8 @@ SUBROUTINE LSMRUC(spp_lsm, & acwaterbudget(i,j) = 0. smtotold(i,j)=0. canwatold(i,j)=0. -! Temporarily!!! -! canwat(i,j)=0. -! For RUC LSM CHKLOWQ needed for MYJPBL should +! for ruc lsm chklowq needed for myjpbl should ! 1 because is actual specific humidity at the surface, and ! not the saturation value chklowq(i,j) = 1. @@ -524,8 +555,8 @@ SUBROUTINE LSMRUC(spp_lsm, & smf (i,j) = 0. evapl (i,j) = 0. prcpl (i,j) = 0. - ENDDO - ENDDO + enddo + enddo do k=1,nsl soilice(k)=0. @@ -535,7 +566,7 @@ SUBROUTINE LSMRUC(spp_lsm, & !----------------------------------------------------------------- - PRCPMS = 0. + prcpms = 0. newsnms = 0. prcpncliq = 0. prcpculiq = 0. @@ -543,52 +574,52 @@ SUBROUTINE LSMRUC(spp_lsm, & prcpcufr = 0. - DO J=jts,jte + do j=jts,jte - DO i=its,ite + do i=its,ite - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' IN LSMRUC ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' in lsmruc ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & ims,ime,jms,jme,its,ite,jts,jte,nzs - print *,' IVGTYP, ISLTYP ', ivgtyp(i,j),isltyp(i,j) - print *,' MAVAIL ', mavail(i,j) - print *,' SOILT,QVG,P8w',soilt(i,j),qvg(i,j),p8w(i,1,j) - print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & + print *,' ivgtyp, isltyp ', ivgtyp(i,j),isltyp(i,j) + print *,' mavail ', mavail(i,j) + print *,' soilt,qvg,p8w',soilt(i,j),qvg(i,j),p8w(i,1,j) + print *, 'lsmruc, i,j,xland, qfx,hfx from sfclay',i,j,xland(i,j), & qfx(i,j),hfx(i,j) - print *, ' GSW, GLW =',gsw(i,j),glw(i,j) - print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) - print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) - print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) - print *, ' I,J=, after SFCLAY CHS,FLHC ',i,j,chs(i,j),flhc(i,j) - print *, 'LSMRUC, IVGTYP,ISLTYP,ALB = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j - print *, 'LSMRUC I,J,DT,RAINBL =',I,J,dt,RAINBL(i,j) - print *, 'XLAND ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j - ENDIF + print *, ' gsw, glw =',gsw(i,j),glw(i,j) + print *, 'soilt, tso start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) + print *, 'soilmois start of time step =',(soilmois(i,k,j),k=1,nsl) + print *, 'smfrozen start of time step =',(smfr3d(i,k,j),k=1,nsl) + print *, ' i,j=, after sfclay chs,flhc ',i,j,chs(i,j),flhc(i,j) + print *, 'lsmruc, ivgtyp,isltyp,alb = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j + print *, 'lsmruc i,j,dt,rainbl =',i,j,dt,rainbl(i,j) + print *, 'xland ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j + endif - ILAND = IVGTYP(i,j) - ISOIL = ISLTYP(I,J) - TABS = T3D(i,kms,j) - QVATM = QV3D(i,kms,j) - QCATM = QC3D(i,kms,j) - PATM = P8w(i,kms,j)*1.e-5 -!-- Z3D(1) is thickness between first full sigma level and the surface, + iland = ivgtyp(i,j) + isoil = isltyp(i,j) + tabs = t3d(i,kms,j) + qvatm = qv3d(i,kms,j) + qcatm = qc3d(i,kms,j) + patm = p8w(i,kms,j)*1.e-5 +!-- z3d(1) is thickness between first full sigma level and the surface, !-- but first mass level is at the half of the first sigma level !-- (u and v are also at the half of first sigma level) - CONFLX = Z3D(i,kms,j)*0.5 - RHO = RHO3D(I,kms,J) + conflx = z3d(i,kms,j)*0.5 + rho = rho3d(i,kms,j) ! -- initialize snow, graupel and ice fractions in frozen precip snowrat = 0. grauprat = 0. icerat = 0. curat = 0. - IF(FRPCPN) THEN + if(frpcpn) then #if (EM_CORE==1) prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j)) prcpncfr = rainncv(i,j)*frzfrac(i,j) !- apply the same frozen precipitation fraction to convective precip -!tgs - 31 mar17 - add safety temperature check in case Thompson MP produces -! frozen precip at T > 273. +!tgs - 31 mar17 - add safety temperature check in case thompson mp produces +! frozen precip at t > 273. if(frzfrac(i,j) > 0..and. tabs < 273.) then prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1.-frzfrac(i,j))) prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))*frzfrac(i,j)) @@ -602,14 +633,14 @@ SUBROUTINE LSMRUC(spp_lsm, & endif ! tabs < 273. endif ! frzfrac > 0. !--- 1*e-3 is to convert from mm/s to m/s - PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3 - NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3 + prcpms = (prcpncliq + prcpculiq)/dt*1.e-3 + newsnms = (prcpncfr + prcpcufr)/dt*1.e-3 - IF ( PRESENT( graupelncv ) ) THEN + if ( present( graupelncv ) ) then graupamt = graupelncv(i,j) - ELSE + else graupamt = 0. - ENDIF + endif if((prcpncfr + prcpcufr) > 0.) then ! -- calculate snow, graupel and ice fractions in falling frozen precip @@ -620,8 +651,8 @@ SUBROUTINE LSMRUC(spp_lsm, & curat=min(1.,max(0.,(prcpcufr/(prcpncfr + prcpcufr)))) endif #else - PRCPMS = (RAINBL(i,j)/DT*1.e-3)*(1-FRZFRAC(I,J)) - NEWSNMS = (RAINBL(i,j)/DT*1.e-3)*FRZFRAC(I,J) + prcpms = (rainbl(i,j)/dt*1.e-3)*(1-frzfrac(i,j)) + newsnms = (rainbl(i,j)/dt*1.e-3)*frzfrac(i,j) if(newsnms == 0.) then snowrat = 0. else @@ -629,34 +660,39 @@ SUBROUTINE LSMRUC(spp_lsm, & endif #endif - ELSE ! .not. FRPCPN + else ! .not. frpcpn if (tabs.le.273.15) then - PRCPMS = 0. - NEWSNMS = RAINBL(i,j)/DT*1.e-3 + prcpms = 0. + newsnms = rainbl(i,j)/dt*1.e-3 !-- here no info about constituents of frozen precipitation, !-- suppose it is all snow snowrat = 1. else - PRCPMS = RAINBL(i,j)/DT*1.e-3 - NEWSNMS = 0. + prcpms = rainbl(i,j)/dt*1.e-3 + newsnms = 0. endif - ENDIF + endif -! -- save time-step water equivalent of frozen precipitation in PRECIPFR array to be used in +! -- save time-step water equivalent of frozen precipitation in precipfr array to be used in ! module_diagnostics - precipfr(i,j) = NEWSNMS * DT *1.e3 + precipfr(i,j) = newsnms * dt *1.e3 -!--- convert exchange coeff QKMS to [m/s] - QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) -! TKMS=FLHC(I,J)/RHO/CP - TKMS=FLHC(I,J)/RHO/(CP*(1.+0.84*QVATM)) ! mynnsfc uses CPM + if (myj) then + qkms=chs(i,j) + tkms=chs(i,j) + else +!--- convert exchange coeff qkms to [m/s] + qkms=flqc(i,j)/rho/mavail(i,j) +! tkms=flhc(i,j)/rho/cp + tkms=flhc(i,j)/rho/(cp*(1.+0.84*qvatm)) ! mynnsfc uses cpm + endif !--- convert incoming snow and canwat from mm to m - SNWE=SNOW(I,J)*1.E-3 - SNHEI=SNOWH(I,J) - CANWATR=CANWAT(I,J)*1.E-3 + snwe=snow(i,j)*1.e-3 + snhei=snowh(i,j) + canwatr=canwat(i,j)*1.e-3 - SNOWFRAC=SNOWC(I,J) - RHOSNFALL=RHOSNF(I,J) + snowfrac=snowc(i,j) + rhosnfall=rhosnf(i,j) snowold(i,j)=snwe !----- @@ -675,184 +711,168 @@ SUBROUTINE LSMRUC(spp_lsm, & enddo !------------------------------------------------------------ -!----- DDZS and DSDZ1 are for implicit solution of soil eqns. +!----- ddzs and dsdz1 are for implicit solution of soil eqns. !------------------------------------------------------------- - NZS1=NZS-1 + nzs1=nzs-1 !----- - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' dt,nzs1, zsmain, zshalf --->', dt,nzs1,zsmain,zshalf + endif - DO K=2,NZS1 - K1=2*K-3 - K2=K1+1 - X=DT/2./(ZSHALF(K+1)-ZSHALF(K)) - DTDZS(K1)=X/(ZSMAIN(K)-ZSMAIN(K-1)) - DTDZS2(K-1)=X - DTDZS(K2)=X/(ZSMAIN(K+1)-ZSMAIN(K)) - END DO + do k=2,nzs1 + k1=2*k-3 + k2=k1+1 + x=dt/2./(zshalf(k+1)-zshalf(k)) + dtdzs(k1)=x/(zsmain(k)-zsmain(k-1)) + dtdzs2(k-1)=x + dtdzs(k2)=x/(zsmain(k+1)-zsmain(k)) + end do -!27jul2011 - CN and SAT are defined in VEGPARM.TBL -! CN=0.5 ! exponent -! SAT=0.0004 ! canopy water saturated - - CW =4.183E6 + cw =4.183e6 -!--- Constants used in Johansen soil thermal +!--- constants used in johansen soil thermal !--- conductivity method - KQWRTZ=7.7 - KICE=2.2 - KWT=0.57 + kqwrtz=7.7 + kice=2.2 + kwt=0.57 !*********************************************************************** -!--- Constants for snow density calculations C1SN and C2SN +!--- constants for snow density calculations c1sn and c2sn c1sn=0.026 -! c1sn=0.01 c2sn=21. !*********************************************************************** - NROOT= 4 -! ! rooting depth + nroot= 4 ! levels in root layer - RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then - RHOSN = SNOW(i,j)/SNOWH(i,j) + rhonewsn = 200. + if(snow(i,j).gt.0. .and. snowh(i,j).gt.0.) then + rhosn = snow(i,j)/snowh(i,j) else - RHOSN = 300. + rhosn = 300. endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then if(ktau.eq.1 .and.(i.eq.358.and.j.eq.260)) & - print *,'before SOILVEGIN - z0,znt(195,254)',z0(i,j),znt(i,j) - ENDIF + print *,'before soilvegin - z0,znt(195,254)',z0(i,j),znt(i,j) + endif !--- initializing soil and surface properties - CALL SOILVEGIN ( mosaic_lu, mosaic_soil,soilfrac,nscat,shdmin(i,j),shdmax(i,j),& - NLCAT,ILAND,ISOIL,iswater,IFOREST,lufrac,VEGFRA(I,J), & - EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j ) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + call soilvegin ( mosaic_lu, mosaic_soil,soilfrac,nscat,shdmin(i,j),shdmax(i,j),& + nlcat,iland,isoil,iswater,myj,iforest,lufrac,vegfra(i,j), & + emissl(i,j),pc(i,j),znt(i,j),lai(i,j),rdlai2d, & + qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j ) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then if(ktau.eq.1 .and.(i.eq.358.and.j.eq.260)) & - print *,'after SOILVEGIN - z0,znt(375,254),lai(375,254)',z0(i,j),znt(i,j),lai(i,j) + print *,'after soilvegin - z0,znt(375,254),lai(375,254)',z0(i,j),znt(i,j),lai(i,j) if(ktau.eq.1 .and. (i.eq.358.and.j.eq.260)) then - print *,'NLCAT,iland,lufrac,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & - NLCAT,iland,lufrac,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j - print *,'NSCAT,soilfrac,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& - NSCAT,soilfrac,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j + print *,'nlcat,iland,lufrac,emissl(i,j),pc(i,j),znt(i,j),lai(i,j)', & + nlcat,iland,lufrac,emissl(i,j),pc(i,j),znt(i,j),lai(i,j),i,j + print *,'nscat,soilfrac,qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt',& + nscat,soilfrac,qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j endif - ENDIF + endif - CN=CFACTR_DATA ! exponent -! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated - SAT = 5.e-4 ! units [m] -! if(i==666.and.j==282) print *,'second 666,282 - sat',sat + cn=cfactr_data ! exponent + sat = 5.e-4 ! units [m] !-- definition of number of soil levels in the rooting zone -! IF(iforest(ivgtyp(i,j)).ne.1) THEN - IF(iforest.gt.2) THEN + if(iforest.gt.2) then !---- all vegetation types except evergreen and mixed forests -!18apr08 - define meltfactor for Egglston melting limit: +!18apr08 - define meltfactor for egglston melting limit: ! for open areas factor is 2, and for forests - factor is 0.85 -! This will make limit on snow melting smaller and let snow stay +! this will make limit on snow melting smaller and let snow stay ! longer in the forests. meltfactor = 2.0 do k=2,nzs if(zsmain(k).ge.0.4) then - NROOT=K + nroot=k goto 111 endif enddo - ELSE + else !---- evergreen and mixed forests !18apr08 - define meltfactor ! meltfactor = 1.5 -! 28 March 11 - Previously used value of metfactor= 1.5 needs to be further reduced +! 28 march 11 - previously used value of metfactor= 1.5 needs to be further reduced ! to compensate for low snow albedos in the forested areas. -! Melting rate in forests will reduce. +! melting rate in forests will reduce. meltfactor = 0.85 do k=2,nzs if(zsmain(k).ge.1.1) then - NROOT=K + nroot=k goto 111 endif enddo - ENDIF + endif 111 continue !----- - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' ZNT, LAI, VEGFRA, SAT, EMIS, PC --->', & - ZNT(I,J),LAI(I,J),VEGFRA(I,J),SAT,EMISSL(I,J),PC(I,J) - print *,' ZS, ZSMAIN, ZSHALF, CONFLX, CN, SAT, --->', zs,zsmain,zshalf,conflx,cn,sat - print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J -! print *,'NROOT, iforest, ivgtyp, i,j ', nroot,iforest(ivgtyp(i,j)),ivgtyp(I,J),I,J - ENDIF - -!!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS -! if(i.eq.397.and.j.eq.562) then -! print *,'RUC LSM - xland(i,j),xice(i,j),snow(i,j)',i,j,xland(i,j),xice(i,j),snow(i,j) -! endif + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' znt, lai, vegfra, sat, emis, pc --->', & + znt(i,j),lai(i,j),vegfra(i,j),sat,emissl(i,j),pc(i,j) + print *,' zs, zsmain, zshalf, conflx, cn, sat, --->', zs,zsmain,zshalf,conflx,cn,sat + print *,'nroot, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(i,j),i,j + endif #if (EM_CORE==1) if(lakemodel==1. .and. lakemask(i,j)==1.) goto 2999 -!Lakes +!lakes #endif - IF((XLAND(I,J)-1.5).GE.0.)THEN -!-- Water - SMAVAIL(I,J)=1.0 - SMMAX(I,J)=1.0 - SNOW(I,J)=0.0 - SNOWH(I,J)=0.0 - SNOWC(I,J)=0.0 - LMAVAIL(I,J)=1.0 + if((xland(i,j)-1.5).ge.0.)then +!-- water + smavail(i,j)=1.0 + smmax(i,j)=1.0 + snow(i,j)=0.0 + snowh(i,j)=0.0 + snowc(i,j)=0.0 + lmavail(i,j)=1.0 - ILAND=iswater - ISOIL=14 + iland=iswater + isoil=14 - patmb=P8w(i,1,j)*1.e-2 - qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB + patmb=p8w(i,1,j)*1.e-2 + qvg (i,j) = qsn(soilt(i,j),tbq)/patmb qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - CHKLOWQ(I,J)=1. - Q2SAT=QSN(TABS,TBQ)/PATMB - - DO K=1,NZS - SOILMOIS(I,K,J)=1.0 - SH2O (I,K,J)=1.0 - TSO(I,K,J)= SOILT(I,J) - ENDDO - - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - PRINT*,' water point, I=',I, & - 'J=',J, 'SOILT=', SOILT(i,j) - ENDIF + chklowq(i,j)=1. + q2sat=qsn(tabs,tbq)/patmb - ELSE + do k=1,nzs + soilmois(i,k,j)=1.0 + sh2o (i,k,j)=1.0 + tso(i,k,j)= soilt(i,j) + enddo + + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print*,' water point, i=',i, & + 'j=',j, 'soilt=', soilt(i,j) + endif -! LAND POINT OR SEA ICE + else + +! land point or sea ice if(xice(i,j).ge.xice_threshold) then -! if(IVGTYP(i,j).eq.isice) then - SEAICE(i,j)=1. + seaice(i,j)=1. else - SEAICE(i,j)=0. + seaice(i,j)=0. endif - IF(SEAICE(I,J).GT.0.5)THEN -!-- Sea-ice case - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - PRINT*,' sea-ice at water point, I=',I, & - 'J=',J - ENDIF -! ILAND = 24 - ILAND = isice - ISOIL = 16 - ZNT(I,J) = 0.011 + if(seaice(i,j).gt.0.5)then +!-- sea-ice case + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print*,' sea-ice at water point, i=',i, & + 'j=',j + endif +! iland = 24 + iland = isice + isoil = 16 + znt(i,j) = 0.011 snoalb(i,j) = 0.75 dqm = 1. ref = 1. @@ -860,56 +880,51 @@ SUBROUTINE LSMRUC(spp_lsm, & wilt = 0. emissl(i,j) = 0.98 - patmb=P8w(i,1,j)*1.e-2 - qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB + patmb=p8w(i,1,j)*1.e-2 + qvg (i,j) = qsn(soilt(i,j),tbq)/patmb qsg (i,j) = qvg(i,j) qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - DO K=1,NZS + do k=1,nzs soilmois(i,k,j) = 1. smfr3d(i,k,j) = 1. sh2o(i,k,j) = 0. keepfr3dflag(i,k,j) = 0. tso(i,k,j) = min(271.4,tso(i,k,j)) - ENDDO - ENDIF + enddo + endif -! Attention!!!! RUC LSM uses soil moisture content minus residual (minimum +! attention!!!! ruc lsm uses soil moisture content minus residual (minimum ! or dry soil moisture content for a given soil type) as a state variable. - DO k=1,nzs + do k=1,nzs ! soilm1d - soil moisture content minus residual [m**3/m**3] soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin),dqm) -! soilm1d (k) = min(max(0.,soilmois(i,k,j)),dqm) tso1d (k) = tso(i,k,j) soiliqw (k) = min(max(0.,sh2o(i,k,j)-qmin),soilm1d(k)) - soilice (k) =(soilm1d (k) - soiliqw (k))/0.9 - ENDDO + soilice (k) =(soilm1d (k) - soiliqw (k))/0.9 + enddo do k=1,nzs smfrkeep(k) = smfr3d(i,k,j) keepfr (k) = keepfr3dflag(i,k,j) enddo - LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(REF-QMIN))) -! LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/dqm)) + lmavail(i,j)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) #if ( NMM_CORE == 1 ) if(ktau+1.gt.1) then #else if(ktau.gt.1) then #endif - -! extract dew from the cloud water at the surface -!30july13 QCG(I,J)=QCG(I,J)-DEW(I,J)/QKMS endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & - i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO - print *,'CONFLX =',CONFLX - print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'land, i,j,tso1d,soilm1d,patm,tabs,qvatm,qcatm,rho', & + i,j,tso1d,soilm1d,patm,tabs,qvatm,qcatm,rho + print *,'conflx =',conflx + print *,'smfrkeep,keepfr ',smfrkeep,keepfr + endif smtotold(i,j)=0. do k=1,nzs-1 @@ -921,89 +936,79 @@ SUBROUTINE LSMRUC(spp_lsm, & (zsmain(nzs)-zshalf(nzs)) canwatold(i,j) = canwatr - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'before SFCTMP, spp_lsm, rstoch, field_sf_loc', & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'before sfctmp, spp_lsm, rstoch, field_sf_loc', & i,j,spp_lsm,(rstoch(i,k,j),k=1,nzs),(field_sf_loc(i,k,j),k=1,nzs) - ENDIF + endif !----------------------------------------------------------------- - CALL SFCTMP (spp_lsm,rstoch(i,:,j),field_sf_loc(i,:,j), & + call sfctmp (spp_lsm,rstoch(i,:,j),field_sf_loc(i,:,j), & dt,ktau,conflx,i,j, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,xland(i,j),ivgtyp(i,j),isltyp(i,j), & - PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN,RHOSNFALL, & + prcpms, newsnms,snwe,snhei,snowfrac, & + rhosn,rhonewsn,rhosnfall, & snowrat,grauprat,icerat,curat, & - PATM,TABS,QVATM,QCATM,RHO, & - GLW(I,J),GSW(I,J),EMISSL(I,J), & - QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & - canwatr,vegfra(I,J),alb(I,J),znt(I,J), & + patm,tabs,qvatm,qcatm,rho, & + glw(i,j),gsw(i,j),emissl(i,j), & + qkms,tkms,pc(i,j),lmavail(i,j), & + canwatr,vegfra(i,j),alb(i,j),znt(i,j), & snoalb(i,j),albbck(i,j),lai(i,j), & !new - myjpbl,seaice(i,j),isice, & + myj,seaice(i,j),isice, & !--- soil fixed fields - QWRTZ, & + qwrtz, & rhocs,dqm,qmin,ref, & wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & - KQWRTZ,KICE,KWT, & + kqwrtz,kice,kwt, & !--- output variables snweprint,snheiprint,rsm, & soilm1d,tso1d,smfrkeep,keepfr, & - soilt(I,J),soilt1(i,j),tsnav(i,j),dew(I,J), & - qvg(I,J),qsg(I,J),qcg(I,J),SMELT(I,J), & - SNOH(I,J),SNFLX(I,J),SNOM(I,J),SNOWFALLAC(I,J), & - ACSNOW(I,J),edir(I,J),ec(I,J),ett(I,J),qfx(I,J), & - lh(I,J),hfx(I,J),sflx(I,J),sublim(I,J), & - evapl(I,J),prcpl(I,J),budget(i,j),runoff1(i,j), & - runoff2(I,J),soilice,soiliqw,infiltrp,smf(i,j)) + soilt(i,j),soilt1(i,j),tsnav(i,j),dew(i,j), & + qvg(i,j),qsg(i,j),qcg(i,j),smelt(i,j), & + snoh(i,j),snflx(i,j),snom(i,j),snowfallac(i,j), & + acsnow(i,j),edir(i,j),ec(i,j),ett(i,j),qfx(i,j), & + lh(i,j),hfx(i,j),sflx(i,j),sublim(i,j), & + evapl(i,j),prcpl(i,j),budget(i,j),runoff1(i,j), & + runoff2(i,j),soilice,soiliqw,infiltrp,smf(i,j)) !----------------------------------------------------------------- -! Fraction of cropland category in the grid box should not have soil moisture below +! irrigation: fraction of cropland category in the grid box should not have soil moisture below ! wilting point during the growing season. -! Let's keep soil moisture 20% above wilting point for the fraction of grid box under +! let's keep soil moisture 10% above wilting point for the fraction of grid box under ! croplands. -! This change violates LSM moisture budget, but -! can be considered as a compensation for irrigation not included into LSM. +! this change violates lsm moisture budget, but +! can be considered as a compensation for irrigation not included into lsm. + + if(mosaic_lu == 1) then + ! greenness factor: between 0 for min greenness and 1 for max greenness. + factor = max(0.,min(1.,(vegfra(i,j)-shdmin(i,j))/max(1.,(shdmax(i,j)-shdmin(i,j))))) - IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN -! IF (ivgtyp(i,j) == crop .and. lai(i,j) > 1.1) THEN -! cropland + if ((lufrac(crop) > 0 .or. lufrac(natural) > 0.).and. factor > 0.75) then + ! cropland or grassland, apply irrigation during the growing seaspon when + ! factor is > 0.75. do k=1,nroot cropsm=1.1*wilt - qmin - if(soilm1d(k) < cropsm*lufrac(crop)) then - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print * ,'Soil moisture is below wilting in cropland category at time step',ktau & + cropfr = min(1.,lufrac(crop) + 0.4*lufrac(natural)) ! assume that 40% of natural is cropland + newsm = cropsm*cropfr + (1.-cropfr)*soilm1d(k) + if(soilm1d(k) < newsm) then + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then +print * ,'soil moisture is below wilting in cropland category at time step',ktau & ,'i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm', & i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm - ENDIF - soilm1d(k) = cropsm*lufrac(crop) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) - ENDIF - endif - enddo - - ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN -! grassland: assume that 40% of grassland is irrigated cropland - do k=1,nroot - cropsm=1.2*wilt - qmin - if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau & - ,'i,j,lufrac(natural),k,soilm1d(k),wilt', & - i,j,lufrac(natural),k,soilm1d(k),wilt - ENDIF - soilm1d(k) = cropsm * lufrac(natural)*0.4 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) - ENDIF + endif + soilm1d(k) = newsm + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print * ,'added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + endif endif enddo - ENDIF + endif ! crop or natural + endif ! mosaic_lu -! Fill in field_sf to pass perturbed field of hydraulic cond. up to model driver and output +! fill in field_sf to pass perturbed field of hydraulic cond. up to model driver and output #if (EM_CORE==1) if (spp_lsm==1) then do k=1,nsl @@ -1012,7 +1017,7 @@ SUBROUTINE LSMRUC(spp_lsm, & endif #endif -!*** DIAGNOSTICS +!*** diagnostics !--- available and maximum soil moisture content in the soil !--- domain @@ -1031,17 +1036,16 @@ SUBROUTINE LSMRUC(spp_lsm, & smmax (i,j) =smmax (i,j)+(qmin+dqm)* & (zsmain(nzs)-zshalf(nzs)) -!--- Convert the water unit into mm - SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - ACRUNOFF(I,J) = ACRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. - SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. +!--- convert the water unit into mm + sfcrunoff(i,j) = sfcrunoff(i,j)+runoff1(i,j)*dt*1000.0 + udrunoff (i,j) = udrunoff(i,j)+runoff2(i,j)*dt*1000.0 + acrunoff(i,j) = acrunoff(i,j)+runoff1(i,j)*dt*1000.0 + smavail (i,j) = smavail(i,j) * 1000. + smmax (i,j) = smmax(i,j) * 1000. + smtotold (i,j) = smtotold(i,j) * 1000. do k=1,nzs -! soilmois(i,k,j) = soilm1d(k) soilmois(i,k,j) = soilm1d(k) + qmin sh2o (i,k,j) = min(soiliqw(k) + qmin,soilmois(i,k,j)) tso(i,k,j) = tso1d(k) @@ -1054,73 +1058,66 @@ SUBROUTINE LSMRUC(spp_lsm, & keepfr3dflag(i,k,j) = keepfr (k) enddo -!tgs add together dew and cloud at the ground surface -!30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - - Z0 (I,J) = ZNT (I,J) - SFCEXC (I,J) = TKMS - patmb=P8w(i,1,j)*1.e-2 - Q2SAT=QSN(TABS,TBQ)/PATMB - QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J)) -! for MYJ PBL scheme - IF((myjpbl).AND.(QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN - CHKLOWQ(I,J)=0. - ELSE - CHKLOWQ(I,J)=1. - ENDIF + z0 (i,j) = znt (i,j) + sfcexc (i,j) = tkms + patmb=p8w(i,1,j)*1.e-2 + q2sat=qsn(tabs,tbq)/patmb + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) +! for myj surface and pbl scheme +! if (myj) then +! myjsfc expects qsfc as actual specific humidity at the surface + if((qvatm.ge.q2sat*0.95).and.qvatm.lt.qvg(i,j))then + chklowq(i,j)=0. + else + chklowq(i,j)=1. + endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - if(CHKLOWQ(I,J).eq.0.) then - print *,'i,j,CHKLOWQ', & - i,j,CHKLOWQ(I,J) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + if(chklowq(i,j).eq.0.) then + print *,'i,j,chklowq', & + i,j,chklowq(i,j) endif - ENDIF + endif - if(snow(i,j)==0.) EMISSL(i,j) = LEMITBL(IVGTYP(i,j)) - EMISS (I,J) = EMISSL(I,J) -! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m - SNOW (i,j) = SNWE*1000. - SNOWH (I,J) = SNHEI - CANWAT (I,J) = CANWATR*1000. + if(snow(i,j)==0.) emissl(i,j) = lemitbl(ivgtyp(i,j)) + emiss (i,j) = emissl(i,j) +! snow is in [mm], snwe is in [m]; canwat is in mm, canwatr is in m + snow (i,j) = snwe*1000. + snowh (i,j) = snhei + canwat (i,j) = canwatr*1000. - INFILTR(I,J) = INFILTRP + infiltr(i,j) = infiltrp - MAVAIL (i,j) = LMAVAIL(I,J) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) - ENDIF -!!! QFX (I,J) = LH(I,J)/LV - SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT - GRDFLX (I,J) = -1. * sflx(I,J) + mavail (i,j) = lmavail(i,j) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' land, i=,j=, qfx, hfx after sfctmp', i,j,lh(i,j),hfx(i,j) + endif + sfcevp (i,j) = sfcevp (i,j) + qfx (i,j) * dt + grdflx (i,j) = -1. * sflx(i,j) ! if(smf(i,j) .ne.0.) then -!tgs - SMF.NE.0. when there is phase change in the top soil layer -! The heat of soil water freezing/thawing is not computed explicitly +!tgs - smf.ne.0. when there is phase change in the top soil layer +! the heat of soil water freezing/thawing is not computed explicitly ! and is responsible for the residual in the energy budget. -! print *,'Budget',budget(i,j),i,j,smf(i,j) +! print *,'budget',budget(i,j),i,j,smf(i,j) ! endif -!--- SNOWC snow cover flag +!--- snowc snow cover flag if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - SNOWFRAC = SNOWFRAC*XICE(I,J) + snowfrac = snowfrac*xice(i,j) endif - SNOWC(I,J)=SNOWFRAC + snowc(i,j)=snowfrac -!--- RHOSNF - density of snowfall - RHOSNF(I,J)=RHOSNFALL +!--- rhosnf - density of snowfall + rhosnf(i,j)=rhosnfall -! Accumulated moisture flux [kg/m^2] - SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT - -!TEST!!!! for test put heat budget term in GRDFLX - -! acbudget(i,j)=acbudget(i,j)+budget(i,j)-smf(i,j) -! GRDFLX (I,J) = acbudget(i,j) +! accumulated moisture flux [kg/m^2] + sfcevp (i,j) = sfcevp (i,j) + qfx (i,j) * dt ! if(smf(i,j) .ne.0.) then -!tgs - SMF.NE.0. when there is phase change in the top soil layer -! The heat of freezing/thawing of soil water is not computed explicitly +!tgs - smf.ne.0. when there is phase change in the top soil layer +! the heat of freezing/thawing of soil water is not computed explicitly ! and is responsible for the residual in the energy budget. ! endif ! budget(i,j)=budget(i,j)-smf(i,j) @@ -1141,296 +1138,308 @@ SUBROUTINE LSMRUC(spp_lsm, & -ac-as - (smavail(i,j)-smtotold(i,j)) -! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & acwaterbudget(i,j)=acwaterbudget(i,j)+waterbudget(i,j) -!!!!TEST use LH to check water budget -! GRDFLX (I,J) = waterbudget(i,j) - - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'smf=',smf(i,j),i,j + print *,'budget',budget(i,j),i,j + print *,'runoff2= ', i,j,runoff2(i,j) + print *,'water budget ', i,j,waterbudget(i,j) print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & smelt(i,j)*dt*1.e3, & (smavail(i,j)-smtotold(i,j)) - print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) - print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) + print *,'snow,snowold',i,j,snwe,snowold(i,j) + print *,'snow-snowold',i,j,max(0.,snwe-snowold(i,j)) + print *,'canwatold, canwat ',i,j,canwatold(i,j),canwat(i,j) print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) - ENDIF + endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'land, i,j,tso1d,soilm1d,soilt - end of time step', & i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) - ENDIF + print *,'land, qfx, hfx after sfctmp', i,j,lh(i,j),hfx(i,j) + endif !--- end of a land or sea ice point - ENDIF + endif 2999 continue ! lakes - ENDDO + enddo - ENDDO + enddo !----------------------------------------------------------------- - END SUBROUTINE LSMRUC + end subroutine lsmruc !----------------------------------------------------------------- - SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & + subroutine sfctmp (spp_lsm,rstochcol,fieldcol_sf, & delt,ktau,conflx,i,j, & !--- input variables nzs,nddzs,nroot,meltfactor, & - ILAND,ISOIL,XLAND,IVGTYP,ISLTYP,PRCPMS, & - NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN,RHOSNFALL, & + iland,isoil,xland,ivgtyp,isltyp,prcpms, & + newsnms,snwe,snhei,snowfrac, & + rhosn,rhonewsn,rhosnfall, & snowrat,grauprat,icerat,curat, & - PATM,TABS,QVATM,QCATM,rho, & - GLW,GSW,EMISS,QKMS,TKMS,PC, & - MAVAIL,CST,VEGFRA,ALB,ZNT, & - ALB_SNOW,ALB_SNOW_FREE,lai, & - MYJ,SEAICE,ISICE, & + patm,tabs,qvatm,qcatm,rho, & + glw,gsw,emiss,qkms,tkms,pc, & + mavail,cst,vegfra,alb,znt, & + alb_snow,alb_snow_free,lai, & + myj,seaice,isice, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & - KQWRTZ,KICE,KWT, & + kqwrtz,kice,kwt, & !--- output variables snweprint,snheiprint,rsm, & soilm1d,ts1d,smfrkeep,keepfr,soilt,soilt1, & tsnav,dew,qvg,qsg,qcg, & - SMELT,SNOH,SNFLX,SNOM,SNOWFALLAC,ACSNOW, & + smelt,snoh,snflx,snom,snowfallac,acsnow, & edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & evapl,prcpl,fltot,runoff1,runoff2,soilice, & soiliqw,infiltr,smf) !----------------------------------------------------------------- - IMPLICIT NONE + implicit none !----------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & + integer, intent(in ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor - REAL, INTENT(IN ) :: C1SN,C2SN - LOGICAL, INTENT(IN ) :: myj -!--- 3-D Atmospheric variables - REAL , & - INTENT(IN ) :: PATM, & - TABS, & - QVATM, & - QCATM - REAL , & - INTENT(IN ) :: GLW, & - GSW, & - PC, & - VEGFRA, & - ALB_SNOW_FREE, & + real, intent(in ) :: delt,conflx,meltfactor + real, intent(in ) :: c1sn,c2sn + logical, intent(in ) :: myj +!--- 3-d atmospheric variables + real , & + intent(in ) :: patm, & + tabs, & + qvatm, & + qcatm + real , & + intent(in ) :: glw, & + gsw, & + pc, & + vegfra, & + alb_snow_free, & lai, & - SEAICE, & - XLAND, & - RHO, & - QKMS, & - TKMS + seaice, & + xland, & + rho, & + qkms, & + tkms - INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP -!--- 2-D variables - REAL , & - INTENT(INOUT) :: EMISS, & - MAVAIL, & - SNOWFRAC, & - ALB_SNOW, & - ALB, & - CST + integer, intent(in ) :: ivgtyp, isltyp +!--- 2-d variables + real , & + intent(inout) :: emiss, & + mavail, & + snowfrac, & + alb_snow, & + alb, & + cst !--- soil properties - REAL :: & - RHOCS, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QMIN, & - QWRTZ, & - REF, & - SAT, & - WILT - - REAL, INTENT(IN ) :: CN, & - CW, & - CP, & - ROVCP, & - G0, & - LV, & - STBOLT, & - KQWRTZ, & - KICE, & - KWT - - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 - - REAL, DIMENSION(1:NZS), INTENT(IN) :: rstochcol - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: fieldcol_sf - - - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real :: & + rhocs, & + bclh, & + dqm, & + ksat, & + psis, & + qmin, & + qwrtz, & + ref, & + sat, & + wilt + + real, intent(in ) :: cn, & + cw, & + cp, & + rovcp, & + g0, & + lv, & + stbolt, & + kqwrtz, & + kice, & + kwt + + real, dimension(1:nzs), intent(in) :: zsmain, & + zshalf, & + dtdzs2 + + real, dimension(1:nzs), intent(in) :: rstochcol + real, dimension(1:nzs), intent(inout) :: fieldcol_sf + + + real, dimension(1:nddzs), intent(in) :: dtdzs + + real, dimension(1:5001), intent(in) :: tbq !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TS1D, & - SOILM1D, & - SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: KEEPFR - - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & - SOILIQW + real, dimension( 1:nzs ) , & + intent(inout) :: ts1d, & + soilm1d, & + smfrkeep + real, dimension( 1:nzs ) , & + intent(inout) :: keepfr + + real, dimension(1:nzs), intent(inout) :: soilice, & + soiliqw - INTEGER, INTENT(INOUT) :: ILAND,ISOIL - INTEGER :: ILANDs + integer, intent(inout) :: iland,isoil + integer :: ilands !-------- 2-d variables - REAL , & - INTENT(INOUT) :: DEW, & - EDIR1, & - EC1, & - ETT1, & - EETA, & - EVAPL, & - INFILTR, & - RHOSN, & - RHONEWSN, & + real , & + intent(inout) :: dew, & + edir1, & + ec1, & + ett1, & + eeta, & + evapl, & + infiltr, & + rhosn, & + rhonewsn, & rhosnfall, & snowrat, & grauprat, & icerat, & curat, & - SUBLIM, & - PRCPL, & - QVG, & - QSG, & - QCG, & - QFX, & - HFX, & + sublim, & + prcpl, & + qvg, & + qsg, & + qcg, & + qfx, & + hfx, & fltot, & smf, & - S, & - RUNOFF1, & - RUNOFF2, & - ACSNOW, & - SNOWFALLAC, & - SNWE, & - SNHEI, & - SMELT, & - SNOM, & - SNOH, & - SNFLX, & - SOILT, & - SOILT1, & - TSNAV, & - ZNT - - REAL, DIMENSION(1:NZS) :: & + s, & + runoff1, & + runoff2, & + acsnow, & + snowfallac, & + snwe, & + snhei, & + smelt, & + snom, & + snoh, & + snflx, & + soilt, & + soilt1, & + tsnav, & + znt + + real, dimension(1:nzs) :: & tice, & rhosice, & capice, & thdifice, & - TS1DS, & - SOILM1DS, & - SMFRKEEPS, & - SOILIQWS, & - SOILICES, & - KEEPFRS + ts1ds, & + soilm1ds, & + smfrkeeps, & + soiliqws, & + soilices, & + keepfrs !-------- 1-d variables - REAL :: & - DEWS, & - MAVAILS, & - EDIR1s, & - EC1s, & + real :: & + dews, & + mavails, & + edir1s, & + ec1s, & csts, & - ETT1s, & - EETAs, & - EVAPLs, & - INFILTRs, & - PRCPLS, & - QVGS, & - QSGS, & - QCGS, & - QFXS, & - HFXS, & + ett1s, & + eetas, & + evapls, & + infiltrs, & + prcpls, & + qvgs, & + qsgs, & + qcgs, & + qfxs, & + hfxs, & fltots, & - RUNOFF1S, & - RUNOFF2s, & - SS, & - SOILTs + runoff1s, & + runoff2s, & + ss, & + soilts - REAL, INTENT(INOUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT - INTEGER, INTENT(IN) :: spp_lsm -!--- Local variables + real, intent(inout) :: rsm, & + snweprint, & + snheiprint + integer, intent(in) :: spp_lsm +!--- local variables - INTEGER :: K,ILNB + integer :: k,ilnb - REAL :: BSN, XSN , & - RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & - T3, UPFLUX, XINET - REAL :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn - REAL :: newsnowratio, dd1 + real :: bsn, xsn , & + rainf, snth, newsn, prcpms, newsnms , & + t3, upflux, xinet + real :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, snowfracnewsn + real :: newsnowratio, dd1, snowfrac2, m - REAL :: rhonewgr,rhonewice + real :: rhonewgr,rhonewice - REAL :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree - REAL :: VEGFRAC, snow_mosaic, snfr, vgfr + real :: rnet,gswnew,gswin,emissn,zntsn,emiss_snowfree + real :: vegfrac, snow_mosaic, snfr, vgfr real :: cice, albice, albsn, drip, dripsn, dripliq real :: interw, intersn, infwater, intwratio !----------------------------------------------------------------- integer, parameter :: ilsnow=99 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' in SFCTMP',i,j,nzs,nddzs,nroot, & - SNWE,RHOSN,SNOM,SMELT,TS1D - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' in sfctmp',i,j,nzs,nddzs,nroot, & + snwe,rhosn,snom,smelt,ts1d + endif + + !-- snow fraction options + !-- option 1: original formulation using critical snow depth to compute + !-- snow fraction + !-- option 2: the tanh formulation from niu,g.-y.,and yang,z.-l. + !2007,jgr,doi:10.1029/2007jd008674. + !-- option 3: the tanh formulation from niu,g.-y.,and yang,z.-l. + !2007,jgr,doi:10.1029/2007jd008674. + ! with vegetation dependent parameters from noah mp (personal + ! communication with mike barlage) + !-- snhei_crit is a threshold for fractional snow in isncovr_opt=1 + snhei_crit=0.01601*rhowater/rhosn + snhei_crit_newsn=0.0005*rhowater/rhosn + !-- + zntsn = z0tbl(isice) snow_mosaic=0. snfr = 1. - NEWSN=0. + newsn=0. newsnowratio = 0. snowfracnewsn=0. + rhonewsn = 100. if(snhei == 0.) snowfrac=0. smelt = 0. - RAINF = 0. - RSM=0. - DD1=0. - INFILTR=0. -! Jul 2016 - Avissar and Pielke (1989) -! This formulation depending on LAI defines relative contribution of the vegetation to + rainf = 0. + rsm=0. + dd1=0. + infiltr=0. +! jul 2016 - Avissar and Pielke (1989) +! this formulation depending on lai defines relative contribution of the vegetation to ! the total heat fluxes between surface and atmosphere. -! With VEGFRA=100% and LAI=3, VEGFRAC=0.86 meaning that vegetation contributes +! with vegfra=100% and lai=3, vegfrac=0.86 meaning that vegetation contributes ! only 86% of the total surface fluxes. -! VGFR=0.01*VEGFRA ! % --> fraction -! VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr) - VEGFRAC=0.01*VEGFRA +! vgfr=0.01*vegfra ! % --> fraction +! vegfrac=2.*lai*vgfr/(1.+2.*lai*vgfr) + vegfrac=0.01*vegfra drip = 0. dripsn = 0. dripliq = 0. @@ -1448,18 +1457,18 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & thdifice(k) = 0. enddo - GSWnew=GSW - GSWin=GSW/(1.-alb) - ALBice=ALB_SNOW_FREE - ALBsn=alb_snow - EMISSN = 0.98 - EMISS_snowfree = LEMITBL(IVGTYP) + gswnew=gsw + gswin=gsw/(1.-alb) + albice=alb_snow_free + albsn=alb_snow + emissn = 0.98 + emiss_snowfree = lemitbl(ivgtyp) !--- sea ice properties -!--- N.N Zubov "Arctic Ice" +!--- n.n Zubov "arctic ice" !--- no salinity dependence because we consider the ice pack !--- to be old and to have low salinity (0.0002) - if(SEAICE.ge.0.5) then + if(seaice.ge.0.5) then do k=1,nzs tice(k) = ts1d(k) - 273.15 rhosice(k) = 917.6/(1-0.000165*tice(k)) @@ -1467,47 +1476,49 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & capice(k) = cice*rhosice(k) thdifice(k) = 2.260872/capice(k) enddo -!-- SEA ICE ALB dependence on ice temperature. When ice temperature is -!-- below critical value of -10C - no change to albedo. -!-- If temperature is higher that -10C then albedo is decreasing. -!-- The minimum albedo at t=0C for ice is 0.1 less. - ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.05, & - ALB_SNOW_FREE - 0.1*(tice(1)+10.)/10. )) +!-- sea ice alb dependence on ice temperature. when ice temperature is +!-- below critical value of -10c - no change to albedo. +!-- if temperature is higher that -10c then albedo is decreasing. +!-- the minimum albedo at t=0c for ice is 0.1 less. + albice = min(alb_snow_free,max(alb_snow_free - 0.05, & + alb_snow_free - 0.1*(tice(1)+10.)/10. )) endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms - print *,'alb_snow_free',ALB_SNOW_FREE - print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',& - GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'alb_snow_free',alb_snow_free + print *,'gsw,gswnew,glw,soilt,emiss,alb,albice,snwe',& + gsw,gswnew,glw,soilt,emiss,alb,albice,snwe + endif if(snhei.gt.0.0081*1.e3/rhosn) then -!*** Update snow density for current temperature (Koren et al. 1999) - BSN=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3) +!*** update snow density for current temperature (koren et al. 1999) + bsn=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3) if(bsn*snwe*100..lt.1.e-4) goto 777 - XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) - rhosn=MIN(MAX(58.8,XSN),500.) ! 13mar18 - switch from 76.9 to 58.8 + xsn=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) + rhosn=min(max(58.8,xsn),500.) ! 13mar18 - switch from 76.9 to 58.8 777 continue endif + !-- snow_mosaic from the previous time step + if(snowfrac < 0.75) snow_mosaic = 1. + newsn=newsnms*delt - IF(NEWSN.GT.0.) THEN -! IF(NEWSN.GE.1.E-8) THEN + if(newsn.gt.0.) then +! if(newsn.ge.1.e-8) then - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *, 'THERE IS NEW SNOW, newsn', newsn - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *, 'there is new snow, newsn', newsn + endif newsnowratio = min(1.,newsn/(snwe+newsn)) -!--- 27 Feb 2014 - empirical formulations from John M. Brown -! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) -!--- 13 Mar 2018 - formulation from Trevor Elcott - rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) - rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) +!--- 27 feb 2014 - empirical formulations from john m. brown +! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-tabs)*0.3333)))) +!--- 13 mar 2018 - formulation from trevor alcott + rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-tabs)*0.15)))) + rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-tabs)*0.3333)))) rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution @@ -1519,64 +1530,57 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & ! from now on rhonewsn is the density of falling frozen precipitation rhonewsn=rhosnfall -!*** Define average snow density of the snow pack considering -!*** the amount of fresh snow (eq. 9 in Koren et al.(1999) +!*** define average snow density of the snow pack considering +!*** the amount of fresh snow (eq. 9 in koren et al.(1999) !*** without snow melt ) xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) - rhosn=MIN(MAX(58.8,XSN),500.) ! 13mar18 - switch from 76.9 to 58.8 + rhosn=min(max(58.8,xsn),500.) ! 13mar18 - switch from 76.9 to 58.8 - ENDIF ! end NEWSN > 0. + endif ! end newsn > 0. - IF(PRCPMS.NE.0.) THEN + if(prcpms.ne.0.) then -! PRCPMS is liquid precipitation rate -! RAINF is a flag used for calculation of rain water -! heat content contribution into heat budget equation. Rain's temperature +! prcpms is liquid precipitation rate +! rainf is a flag used for calculation of rain water +! heat content contribution into heat budget equation. rain's temperature ! is set equal to air temperature at the first atmospheric ! level. - RAINF=1. - ENDIF + rainf=1. + endif drip = 0. intwratio=0. if(vegfrac > 0.01) then -! compute intercepted precipitation - Eq. 1 Lawrence et al., -! J. of Hydrometeorology, 2006, CLM. - interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac - intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac - infwater=PRCPMS - interw/delt +! compute intercepted precipitation - eq. 1 Lawrence et al., +! j. of hydrometeorology, 2006, clm. + interw=0.25*delt*prcpms*(1.-exp(-0.5*lai))*vegfrac + intersn=0.25*newsn*(1.-exp(-0.5*lai))*vegfrac + infwater=prcpms - interw/delt if((interw+intersn) > 0.) then intwratio=interw/(interw+intersn) endif -! Update water/snow intercepted by the canopy - dd1=CST + interw + intersn - CST=DD1 - IF(CST.GT.SAT) THEN - CST=SAT - DRIP=DD1-SAT - ENDIF +! update water/snow intercepted by the canopy + dd1=cst + interw + intersn + cst=dd1 + if(cst.gt.sat) then + cst=sat + drip=dd1-sat + endif else - CST=0. - DRIP=0. + cst=0. + drip=0. interw=0. intersn=0. - infwater=PRCPMS + infwater=prcpms endif ! vegfrac > 0.01 -! SNHEI_CRIT is a threshold for fractional snow - SNHEI_CRIT=0.01601*1.e3/rhosn - SNHEI_CRIT_newsn=0.0005*1.e3/rhosn -! snowfrac from the previous time step - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) - if(snowfrac < 0.75) snow_mosaic = 1. - - IF(NEWSN.GT.0.) THEN -!Update snow on the ground + if(newsn.gt.0.) then +!update snow on the ground snwe=max(0.,snwe+newsn-intersn) -! Add drip to snow on the ground +! add drip to snow on the ground if(drip > 0.) then if (snow_mosaic==1.) then dripliq=drip*intwratio @@ -1590,167 +1594,194 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & endif endif snhei=snwe*rhowater/rhosn - NEWSN=NEWSN*rhowater/rhonewsn - ENDIF - - IF(SNHEI.GT.0.0) THEN -!-- SNOW on the ground -!--- Land-use category should be changed to snow/ice for grid points with snow>0 - ILAND=ISICE -!24nov15 - based on field exp on Pleasant View soccer fields + newsn=newsn*rhowater/rhonewsn + endif + + if(snhei.gt.0.0) then +!-- snow on the ground +!--- land-use category should be changed to snow/ice for grid points with snow>0 + iland=isice +!24nov15 - based on field exp on pleasant view soccer fields ! if(meltfactor > 1.5) then ! all veg. types, except forests -! SNHEI_CRIT=0.01601*1.e3/rhosn -! Petzold - 1 cm of fresh snow overwrites effects from old snow. -! Need to test SNHEI_CRIT_newsn=0.01 -! SNHEI_CRIT_newsn=0.01 +! snhei_crit=0.01601*1.e3/rhosn +! petzold - 1 cm of fresh snow overwrites effects from old snow. +! need to test snhei_crit_newsn=0.01 +! snhei_crit_newsn=0.01 ! else ! forests -! SNHEI_CRIT=0.02*1.e3/rhosn -! SNHEI_CRIT_newsn=0.001*1.e3/rhosn +! snhei_crit=0.02*1.e3/rhosn +! snhei_crit_newsn=0.001*1.e3/rhosn ! endif - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -!24nov15 - SNOWFRAC for urban category < 0.75 + if(isncovr_opt == 1) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + elseif(isncovr_opt == 2) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + !if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + ! snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**1.)) + !else + !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests + ! on 3-km scale use actual roughness, but not higher than 0.2 m. + ! the factor is 20 for forests (~100/dx = 33., dx=3 km) + snowfrac2 = tanh( snhei/(2.5 * min(0.2,znt) *(rhosn/rhonewsn)**1.)) + !endif + !-- snow fraction is average between method 1 and 2 + snowfrac = 0.5*(snowfrac+snowfrac2) + else + !-- isncovr_opt=3 + !m = mfsno(ivgtyp) ! vegetation dependent facsnf/msnf from noah mp + m = 1. + !-- for rrfs a factor 10. was added to 'facsnf' to get reasonal values of + ! snow cover fractions on the 3-km scale. + ! this factor is scale dependent. + snowfrac = tanh( snhei/(10. * sncovfac(ivgtyp)*(rhosn/rhonewsn)**m)) + endif + + if(newsn > 0. ) then + snowfracnewsn=min(1.,snowfallac*1.e-3/snhei_crit_newsn) + endif + +!24nov15 - snowfrac for urban category < 0.75 if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) ! if(meltfactor > 1.5) then ! if(isltyp > 9 .and. isltyp < 13) then -!24nov15 clay soil types - SNOFRAC < 0.9 +!24nov15 clay soil types - snofrac < 0.9 ! snowfrac=min(0.9,snowfrac) ! endif ! else -!24nov15 - SNOWFRAC for forests < 0.75 +!24nov15 - snowfrac for forests < 0.75 ! snowfrac=min(0.85,snowfrac) ! endif -! SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -! elseif(snowfrac < 0.3 .and. tabs > 275.) then - if(snowfrac < 0.75) snow_mosaic = 1. - if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) - - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN + keep_snow_albedo = 0. + if (snowfracnewsn > 0.99 .and. rhosnfall < 450.) then ! new snow - KEEP_SNOW_ALBEDO = 1. - snow_mosaic=0. ! ??? - ENDIF + keep_snow_albedo = 1. + snow_mosaic=0. + endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn', & - SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snhei_crit,snowfrac,snhei_crit_newsn,snowfracnewsn', & + snhei_crit,snowfrac,snhei_crit_newsn,snowfracnewsn + endif -!-- Set znt for snow from VEGPARM table (snow/ice landuse), except for +!-- set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). -!5mar12 IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) -! IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) - IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then - if( snhei .le. 2.*ZNT)then + if(newsn.eq.0. .and. znt.le.0.2 .and. ivgtyp.ne.isice) then + if( snhei .le. 2.*znt)then znt=0.55*znt+0.45*z0tbl(iland) - elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then + elseif( snhei .gt. 2.*znt .and. snhei .le. 4.*znt)then znt=0.2*znt+0.8*z0tbl(iland) - elseif(snhei > 4.*ZNT) then + elseif(snhei > 4.*znt) then znt=z0tbl(iland) endif - ENDIF - - -!--- GSWNEW in-coming solar for snow on land or on ice -! GSWNEW=GSWnew/(1.-ALB) -!-- Time to update snow and ice albedo + endif - IF(SEAICE .LT. 0.5) THEN -!----- SNOW on soil -!-- ALB dependence on snow depth -! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this -! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4 + if(seaice .lt. 0.5) then +!----- snow on soil +!-- alb dependence on snow depth +! alb_snow across canada's forested areas is very low - 0.27-0.35, this +! causes significant warm biases. limiting alb in these areas to be higher than 0.4 ! hwlps with these biases.. if( snow_mosaic == 1.) then - ALBsn=alb_snow -! ALBsn=max(0.4,alb_snow) - Emiss= emissn + albsn=alb_snow + if(keep_snow_albedo > 0.9 .and. albsn < 0.4) then + !-- Albedo correction with fresh snow and deep snow pack + !-- will reduce warm bias in western Canada + !-- and US West coast, where max snow albedo is low (0.3-0.5). + !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j + albsn = 0.7 + endif + + emiss= emissn else - ALBsn = MAX(keep_snow_albedo*alb_snow, & - MIN((alb_snow_free + & + albsn = max(keep_snow_albedo*alb_snow, & + min((alb_snow_free + & (alb_snow - alb_snow_free) * snowfrac), alb_snow)) - - Emiss = MAX(keep_snow_albedo*emissn, & - MIN((emiss_snowfree + & + if(newsn > 0. .and. keep_snow_albedo > 0.9 .and. albsn < 0.4) then + !-- Albedo correction with fresh snow and deep snow pack + !-- will reduce warm bias in western Canada + !-- and US West coast, where max snow albedo is low (0.3-0.5). + !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j + albsn = 0.7 + !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j + endif + + emiss = max(keep_snow_albedo*emissn, & + min((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.279.and.j.eq.263) then - print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snow on soil albsn,emiss,snow_mosaic',i,j,albsn,emiss,snow_mosaic + endif !28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is ! higher than patchy snow treshold - then snow albedo is not less than 0.55 -! (inspired by the flight from Fairbanks to Seatle) - +! (inspired by the flight from fairbanks to seatle) !test if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then ! albsn=max(alb_snow,0.55) ! endif -!-- ALB dependence on snow temperature. When snow temperature is -!-- below critical value of -10C - no change to albedo. -!-- If temperature is higher that -10C then albedo is decreasing. -!-- The minimum albedo at t=0C for snow on land is 15% less than -!-- albedo of temperatures below -10C. +!-- alb dependence on snow temperature. when snow temperature is +!-- below critical value of -10c - no change to albedo. +!-- if temperature is higher that -10c then albedo is decreasing. +!-- the minimum albedo at t=0c for snow on land is 15% less than +!-- albedo of temperatures below -10c. if(albsn.lt.0.4 .or. keep_snow_albedo==1) then - ALB=ALBsn -! ALB=max(0.4,alb_snow) + alb=albsn else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 - ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & - (273.15-263.15)*ALBSN, ALBSN - 0.05)) + alb = min(albsn,max(albsn - 0.1*(soilt - 263.15)/ & + (273.15-263.15)*albsn, albsn - 0.05)) endif - ELSE -!----- SNOW on ice + else +!----- snow on ice if( snow_mosaic == 1.) then - ALBsn=alb_snow - Emiss= emissn + albsn=alb_snow + emiss= emissn else - ALBsn = MAX(keep_snow_albedo*alb_snow, & - MIN((albice + (alb_snow - albice) * snowfrac), alb_snow)) - Emiss = MAX(keep_snow_albedo*emissn, & - MIN((emiss_snowfree + & + albsn = max(keep_snow_albedo*alb_snow, & + min((albice + (alb_snow - albice) * snowfrac), alb_snow)) + emiss = max(keep_snow_albedo*emissn, & + min((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'Snow on ice snow_mosaic,ALBsn,emiss',i,j,ALBsn,emiss,snow_mosaic - ENDIF -!-- ALB dependence on snow temperature. When snow temperature is -!-- below critical value of -10C - no change to albedo. -!-- If temperature is higher that -10C then albedo is decreasing. + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snow on ice snow_mosaic,albsn,emiss',i,j,albsn,emiss,snow_mosaic + endif +!-- alb dependence on snow temperature. when snow temperature is +!-- below critical value of -10c - no change to albedo. +!-- if temperature is higher that -10c then albedo is decreasing. if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.1.)then - ALB=ALBsn + alb=albsn else !-- change albedo when no fresh snow - ALB = MIN(ALBSN,MAX(ALBSN - 0.15*ALBSN*(soilt - 263.15)/ & - (273.15-263.15), ALBSN - 0.1)) + alb = min(albsn,max(albsn - 0.15*albsn*(soilt - 263.15)/ & + (273.15-263.15), albsn - 0.1)) endif - ENDIF + endif if (snow_mosaic==1.) then !may 2014 - treat separately snow-free and snow-covered areas - if(SEAICE .LT. 0.5) then -! LAND + if(seaice .lt. 0.5) then +! land ! portion not covered with snow -! compute absorbed GSW for snow-free portion +! compute absorbed gsw for snow-free portion - gswnew=GSWin*(1.-alb_snow_free) + gswnew=gswin*(1.-alb_snow_free) !-------------- - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT - XINET = EMISS_snowfree*(GLW-UPFLUX) - RNET = GSWnew + XINET - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Fractional snow - snowfrac=',snowfrac - print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet - ENDIF + t3 = stbolt*soilt*soilt*soilt + upflux = t3 *soilt + xinet = emiss_snowfree*(glw-upflux) + rnet = gswnew + xinet + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'fractional snow - snowfrac=',snowfrac + print *,'snowfrac<1 gswin,gswnew -',gswin,gswnew,'soilt, rnet',soilt,rnet + endif do k=1,nzs soilm1ds(k) = soilm1d(k) ts1ds(k) = ts1d(k) @@ -1770,20 +1801,19 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & runoff2s=0. ilands = ivgtyp - - CALL SOIL(spp_lsm,rstochcol,fieldcol_sf, & + call soil(spp_lsm,rstochcol,fieldcol_sf, & !--- input variables i,j,ilands,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & - EMISS_snowfree,RNET,QKMS,TKMS,PC,csts,dripliq, & + prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,gswin, & + emiss_snowfree,rnet,qkms,tkms,pc,csts,dripliq, & infwater,rho,vegfrac,lai,myj, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt, & + qwrtz,rhocs,dqm,qmin,ref,wilt, & psis,bclh,ksat,sat,cn, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - lv,CP,rovcp,G0,cw,stbolt,tabs, & - KQWRTZ,KICE,KWT, & + lv,cp,rovcp,g0,cw,stbolt,tabs, & + kqwrtz,kice,kwt, & !--- output variables for snow-free portion soilm1ds,ts1ds,smfrkeeps,keepfrs, & dews,soilts,qvgs,qsgs,qcgs,edir1s,ec1s, & @@ -1791,21 +1821,20 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & runoff2s,mavails,soilices,soiliqws, & infiltrs,smf) else -! SEA ICE +! sea ice ! portion not covered with snow -! compute absorbed GSW for snow-free portion +! compute absorbed gsw for snow-free portion - gswnew=GSWin*(1.-albice) + gswnew=gswin*(1.-albice) !-------------- - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT - XINET = EMISS_snowfree*(GLW-UPFLUX) - RNET = GSWnew + XINET - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Fractional snow - snowfrac=',snowfrac - print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet - ENDIF + t3 = stbolt*soilt*soilt*soilt + upflux = t3 *soilt + xinet = emiss_snowfree*(glw-upflux) + rnet = gswnew + xinet + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'fractional snow - snowfrac=',snowfrac + print *,'snowfrac<1 gswin,gswnew -',gswin,gswnew,'soilt, rnet',soilt,rnet + endif do k=1,nzs ts1ds(k) = ts1d(k) enddo @@ -1817,16 +1846,16 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & runoff1s=0. runoff2s=0. - CALL SICE( & + call sice( & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - 0.98,RNET,QKMS,TKMS,rho,myj, & + prcpms,rainf,patm,qvatm,qcatm,glw,gswnew, & + 0.98,rnet,qkms,tkms,rho,myj, & !--- sea ice parameters tice,rhosice,capice,thdifice, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - lv,CP,rovcp,cw,stbolt,tabs, & + lv,cp,rovcp,cw,stbolt,tabs, & !--- output variable ts1ds,dews,soilts,qvgs,qsgs,qcgs, & eetas,qfxs,hfxs,ss,evapls,prcpls,fltots & @@ -1849,89 +1878,84 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & endif ! seaice < 0.5 !return gswnew to incoming solar - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.442.and.j.eq.260) then + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb - ENDIF -! gswnew=gswnew/(1.-alb_snow_free) + endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Incoming GSWnew snowfrac<1 -',gswnew - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'incoming gswnew snowfrac<1 -',gswnew + endif endif ! snow_mosaic=1. !--- recompute absorbed solar radiation and net radiation -!--- for updated value of snow albedo - ALB - gswnew=GSWin*(1.-alb) -! print *,'SNOW fraction GSWnew',gswnew,'alb=',alb +!--- for updated value of snow albedo - alb + gswnew=gswin*(1.-alb) +! print *,'snow fraction gswnew',gswnew,'alb=',alb !-------------- - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT - XINET = EMISS*(GLW-UPFLUX) - RNET = GSWnew + XINET - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.442.and.j.eq.260) then -! if(i.eq.271.and.j.eq.242) then - print *,'RNET=',rnet - print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& - i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB - ENDIF + t3 = stbolt*soilt*soilt*soilt + upflux = t3 *soilt + xinet = emiss*(glw-upflux) + rnet = gswnew + xinet + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'rnet=',rnet + print *,'snow - i,j,newsn,snwe,snhei,gsw,gswnew,glw,upflux,alb',& + i,j,newsn,snwe,snhei,gsw,gswnew,glw,upflux,alb + endif - if (SEAICE .LT. 0.5) then -! LAND + if (seaice .lt. 0.5) then +! land if(snow_mosaic==1.)then snfr=1. else snfr=snowfrac endif - CALL SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf, & !--- input variables + call snowsoil (spp_lsm,rstochcol,fieldcol_sf, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - meltfactor,rhonewsn,SNHEI_CRIT, & ! new - ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & - RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,GSWin,EMISS,RNET,IVGTYP, & - QKMS,TKMS,PC,CST,dripsn,infwater, & - RHO,VEGFRAC,ALB,ZNT,lai, & - MYJ, & + meltfactor,rhonewsn,snhei_crit, & ! new + iland,prcpms,rainf,newsn,snhei,snwe,snfr, & + rhosn,patm,qvatm,qcatm, & + glw,gswnew,gswin,emiss,rnet,ivgtyp, & + qkms,tkms,pc,cst,dripsn,infwater, & + rho,vegfrac,alb,znt,lai, & + myj, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - lv,CP,rovcp,G0,cw,stbolt,tabs, & - KQWRTZ,KICE,KWT, & + lv,cp,rovcp,g0,cw,stbolt,tabs, & + kqwrtz,kice,kwt, & !--- output variables ilnb,snweprint,snheiprint,rsm, & soilm1d,ts1d,smfrkeep,keepfr, & dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & - SMELT,SNOH,SNFLX,SNOM,edir1,ec1,ett1,eeta, & + smelt,snoh,snflx,snom,edir1,ec1,ett1,eeta, & qfx,hfx,s,sublim,prcpl,fltot,runoff1,runoff2, & mavail,soilice,soiliqw,infiltr ) else -! SEA ICE +! sea ice if(snow_mosaic==1.)then snfr=1. else snfr=snowfrac endif - CALL SNOWSEAICE ( & + call snowseaice ( & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & - meltfactor,rhonewsn,SNHEI_CRIT, & ! new - ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & - RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,EMISS,RNET, & - QKMS,TKMS,RHO,myj, & + meltfactor,rhonewsn,snhei_crit, & ! new + iland,prcpms,rainf,newsn,snhei,snwe,snfr, & + rhosn,patm,qvatm,qcatm, & + glw,gswnew,emiss,rnet, & + qkms,tkms,rho,myj, & !--- sea ice parameters - ALB,ZNT, & + alb,znt, & tice,rhosice,capice,thdifice, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - lv,CP,rovcp,cw,stbolt,tabs, & + lv,cp,rovcp,cw,stbolt,tabs, & !--- output variables ilnb,snweprint,snheiprint,rsm,ts1d, & dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & - SMELT,SNOH,SNFLX,SNOM,eeta, & + smelt,snoh,snflx,snom,eeta, & qfx,hfx,s,sublim,prcpl,fltot & ) edir1 = eeta*1.e-3 @@ -1952,27 +1976,20 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & endif - if(snhei.eq.0.) then -!--- all snow is melted - alb=alb_snow_free - iland=ivgtyp - endif - if (snow_mosaic==1.) then -! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, +! may 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, ! etc. - if(SEAICE .LT. 0.5) then -! LAND - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'SOILT snow on land', ktau, i,j,soilt - print *,'SOILT on snow-free land', i,j,soilts + if(seaice .lt. 0.5) then +! land + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'soilt snow on land', ktau, i,j,soilt + print *,'soilt on snow-free land', i,j,soilts print *,'ts1d,ts1ds',i,j,ts1d,ts1ds - print *,' SNOW flux',i,j, snflx - print *,' Ground flux on snow-covered land',i,j, s - print *,' Ground flux on snow-free land', i,j,ss - print *,' CSTS, CST', i,j,csts,cst - ENDIF + print *,' snow flux',i,j, snflx + print *,' ground flux on snow-covered land',i,j, s + print *,' ground flux on snow-free land', i,j,ss + print *,' csts, cst', i,j,csts,cst + endif do k=1,nzs soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac @@ -2003,39 +2020,29 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac !alb - ALB = MAX(keep_snow_albedo*alb, & - MIN((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) + alb = max(keep_snow_albedo*alb, & + min((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) - Emiss = MAX(keep_snow_albedo*emissn, & - MIN((emiss_snowfree + & + emiss = max(keep_snow_albedo*emissn, & + min((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) -! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac -! emiss=emiss_snowfree*(1.-snowfrac) + emissn*snowfrac - -! if(abs(fltot) > 2.) then -! print *,'i,j,fltot,snowfrac,fltots',fltot,snowfrac,fltots,i,j -! endif runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac - smelt = smelt * snowfrac - snoh = snoh * snowfrac - snflx = snflx * snowfrac - snom = snom * snowfrac mavail = mavails*(1.-snowfrac) + 1.*snowfrac infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' Ground flux combined', i,j, s - print *,'SOILT combined on land', soilt - print *,'TS combined on land', ts1d - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' ground flux combined', i,j, s + print *,'soilt combined on land', soilt + print *,'ts combined on land', ts1d + endif else -! SEA ICE -! Now combine fluxes for snow-free sea ice and snow-covered area - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SOILT snow on ice', soilt - ENDIF +! sea ice +! now combine fluxes for snow-free sea ice and snow-covered area + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'soilt snow on ice', soilt + endif do k=1,nzs ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac enddo @@ -2052,61 +2059,92 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac !alb - ALB = MAX(keep_snow_albedo*alb, & - MIN((albice + (alb - alb_snow_free) * snowfrac), alb)) + alb = max(keep_snow_albedo*alb, & + min((albice + (alb - alb_snow_free) * snowfrac), alb)) - Emiss = MAX(keep_snow_albedo*emissn, & - MIN((emiss_snowfree + & + emiss = max(keep_snow_albedo*emissn, & + min((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) -! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac -! emiss=1.*(1.-snowfrac) + emissn*snowfrac runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac - smelt = smelt * snowfrac - snoh = snoh * snowfrac - snflx = snflx * snowfrac - snom = snom * snowfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SOILT combined on ice', soilt - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'soilt combined on ice', soilt + endif endif endif ! snow_mosaic = 1. + if(snhei.eq.0.) then + !-- all snow is melted + alb=alb_snow_free + iland=ivgtyp + else + !-- snow on the ground + if(isncovr_opt == 1) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + elseif(isncovr_opt == 2) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + !if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + ! snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**1.)) + !else + !-- niu&yang: znt=0.01 m for 1 degree (100km) resolution tests + ! on 3-km scale use actual roughness, but not higher than 0.2 m. + ! the factor is 20 for forests (~100/dx = 33.) + snowfrac2 = tanh( snhei/(2.5 * min(0.2,znt) *(rhosn/rhonewsn)**1.)) + !endif + !-- snow fraction is average between method 1 and 2 + snowfrac = 0.5*(snowfrac+snowfrac2) + else + !-- isncovr_opt=3 + !m = mfsno(ivgtyp) ! vegetation dependent facsnf/msnf from noah mp + m = 1. + !-- for rrfs a factor 10. was added to 'facsnf' to get reasonal values + !of + ! snow cover fractions on the 3-km scale. + ! this factor is scale dependent. + snowfrac = tanh( snhei/(10. * sncovfac(ivgtyp)*(rhosn/rhonewsn)**m)) + endif + + endif + + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + ! run-total accumulated snow based on snowfall and snowmelt in [m] - snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) + snowfallac = snowfallac + newsn * 1.e3 ! accumulated snow depth [mm], using variable snow den + !snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) - ELSE + else !--- no snow snheiprint=0. snweprint=0. smelt=0. !-------------- - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT - XINET = EMISS*(GLW-UPFLUX) - RNET = GSWnew + XINET - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'NO snow on the ground GSWnew -',GSWnew,'RNET=',rnet - ENDIF + t3 = stbolt*soilt*soilt*soilt + upflux = t3 *soilt + xinet = emiss*(glw-upflux) + rnet = gswnew + xinet + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'no snow on the ground gswnew -',gswnew,'rnet=',rnet + endif - if(SEAICE .LT. 0.5) then -! LAND - CALL SOIL(spp_lsm,rstochcol,fieldcol_sf, & + if(seaice .lt. 0.5) then +! land + call soil(spp_lsm,rstochcol,fieldcol_sf, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & - EMISS,RNET,QKMS,TKMS,PC,cst,drip,infwater, & + prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,gswin, & + emiss,rnet,qkms,tkms,pc,cst,drip,infwater, & rho,vegfrac,lai,myj, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt, & + qwrtz,rhocs,dqm,qmin,ref,wilt, & psis,bclh,ksat,sat,cn, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - lv,CP,rovcp,G0,cw,stbolt,tabs, & - KQWRTZ,KICE,KWT, & + lv,cp,rovcp,g0,cw,stbolt,tabs, & + kqwrtz,kice,kwt, & !--- output variables soilm1d,ts1d,smfrkeep,keepfr, & dew,soilt,qvg,qsg,qcg,edir1,ec1, & @@ -2114,23 +2152,23 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & runoff2,mavail,soilice,soiliqw, & infiltr,smf) else -! SEA ICE -! If current ice albedo is not the same as from the previous time step, then -! update GSW, ALB and RNET for surface energy budget - if(ALB.ne.ALBice) GSWnew=GSW/(1.-ALB)*(1.-ALBice) +! sea ice +! if current ice albedo is not the same as from the previous time step, then +! update gsw, alb and rnet for surface energy budget + if(alb.ne.albice) gswnew=gsw/(1.-alb)*(1.-albice) alb=albice - RNET = GSWnew + XINET + rnet = gswnew + xinet - CALL SICE( & + call sice( & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - EMISS,RNET,QKMS,TKMS,rho,myj, & + prcpms,rainf,patm,qvatm,qcatm,glw,gswnew, & + emiss,rnet,qkms,tkms,rho,myj, & !--- sea ice parameters tice,rhosice,capice,thdifice, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - lv,CP,rovcp,cw,stbolt,tabs, & + lv,cp,rovcp,cw,stbolt,tabs, & !--- output variables ts1d,dew,soilt,qvg,qsg,qcg, & eeta,qfx,hfx,s,evapl,prcpl,fltot & @@ -2152,55 +2190,55 @@ SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf, & enddo endif - ENDIF + endif -! RETURN -! END +! return +! end !--------------------------------------------------------------- - END SUBROUTINE SFCTMP + end subroutine sfctmp !--------------------------------------------------------------- - FUNCTION QSN(TN,T) + function qsn(tn,t) !**************************************************************** - REAL, DIMENSION(1:5001), INTENT(IN ) :: T - REAL, INTENT(IN ) :: TN - - REAL QSN, R,R1,R2 - INTEGER I - - R=(TN-173.15)/.05+1. - I=INT(R) - IF(I.GE.1) goto 10 - I=1 - R=1. - 10 IF(I.LE.5000) GOTO 20 - I=5000 - R=5001. - 20 R1=T(I) - R2=R-I - QSN=(T(I+1)-R1)*R2 + R1 -! print *,' in QSN, I,R,R1,R2,T(I+1),TN, QSN', I,R,r1,r2,t(i+1),tn,QSN -! RETURN -! END + real, dimension(1:5001), intent(in ) :: t + real, intent(in ) :: tn + + real qsn, r,r1,r2 + integer i + + r=(tn-173.15)/.05+1. + i=int(r) + if(i.ge.1) goto 10 + i=1 + r=1. + 10 if(i.le.5000) goto 20 + i=5000 + r=5001. + 20 r1=t(i) + r2=r-i + qsn=(t(i+1)-r1)*r2 + r1 +! print *,' in qsn, i,r,r1,r2,t(i+1),tn, qsn', i,r,r1,r2,t(i+1),tn,qsn +! return +! end !----------------------------------------------------------------------- - END FUNCTION QSN + end function qsn !------------------------------------------------------------------------ - SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & + subroutine soil (spp_lsm,rstochcol, fieldcol_sf, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& - PRCPMS,RAINF,PATM,QVATM,QCATM, & - GLW,GSW,GSWin,EMISS,RNET, & - QKMS,TKMS,PC,cst,drip,infwater,rho,vegfrac,lai, & + prcpms,rainf,patm,qvatm,qcatm, & + glw,gsw,gswin,emiss,rnet, & + qkms,tkms,pc,cst,drip,infwater,rho,vegfrac,lai, & myj, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - xlv,CP,rovcp,G0_P,cw,stbolt,TABS, & - KQWRTZ,KICE,KWT, & + xlv,cp,rovcp,g0_p,cw,stbolt,tabs, & + kqwrtz,kice,kwt, & !--- output variables soilmois,tso,smfrkeep,keepfr, & dew,soilt,qvg,qsg,qcg, & @@ -2209,195 +2247,193 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & soiliqw,infiltrp,smf) !************************************************************* -! Energy and moisture budget for vegetated surfaces -! without snow, heat diffusion and Richards eqns. in +! energy and moisture budget for vegetated surfaces +! without snow, heat diffusion and richards eqns. in ! soil ! -! DELT - time step (s) +! delt - time step (s) ! ktau - numver of time step -! CONFLX - depth of constant flux layer (m) -! J,I - the location of grid point -! IME, JME, KME, NZS - dimensions of the domain -! NROOT - number of levels within the root zone -! PRCPMS - precipitation rate in m/s -! PATM - pressure [bar] -! QVATM,QCATM - cloud and water vapor mixing ratio (kg/kg) +! conflx - depth of constant flux layer (m) +! j,i - the location of grid point +! ime, jme, kme, nzs - dimensions of the domain +! nroot - number of levels within the root zone +! prcpms - precipitation rate in m/s +! patm - pressure [bar] +! qvatm,qcatm - cloud and water vapor mixing ratio (kg/kg) ! at the first atm. level -! GLW, GSW - incoming longwave and absorbed shortwave -! radiation at the surface (W/m^2) -! EMISS,RNET - emissivity of the ground surface (0-1) and net -! radiation at the surface (W/m^2) -! QKMS - exchange coefficient for water vapor in the +! glw, gsw - incoming longwave and absorbed shortwave +! radiation at the surface (w/m^2) +! emiss,rnet - emissivity of the ground surface (0-1) and net +! radiation at the surface (w/m^2) +! qkms - exchange coefficient for water vapor in the ! surface layer (m/s) -! TKMS - exchange coefficient for heat in the surface +! tkms - exchange coefficient for heat in the surface ! layer (m/s) -! PC - plant coefficient (resistance) (0-1) -! RHO - density of atmosphere near sueface (kg/m^3) -! VEGFRAC - greeness fraction -! RHOCS - volumetric heat capacity of dry soil -! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3) -! REF, WILT - field capacity soil moisture and the +! pc - plant coefficient (resistance) (0-1) +! rho - density of atmosphere near sueface (kg/m^3) +! vegfrac - greeness fraction +! rhocs - volumetric heat capacity of dry soil +! dqm, qmin - porosity minus residual soil moisture qmin (m^3/m^3) +! ref, wilt - field capacity soil moisture and the ! wilting point (m^3/m^3) -! PSIS - matrix potential at saturation (m) -! BCLH - exponent for Clapp-Hornberger parameterization -! KSAT - saturated hydraulic conductivity (m/s) -! SAT - maximum value of water intercepted by canopy (m) -! CN - exponent for calculation of canopy water -! ZSMAIN - main levels in soil (m) -! ZSHALF - middle of the soil layers (m) -! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil -! TBQ - table to define saturated mixing ration +! psis - matrix potential at saturation (m) +! bclh - exponent for clapp-hornberger parameterization +! ksat - saturated hydraulic conductivity (m/s) +! sat - maximum value of water intercepted by canopy (m) +! cn - exponent for calculation of canopy water +! zsmain - main levels in soil (m) +! zshalf - middle of the soil layers (m) +! dtdzs,dtdzs2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil +! tbq - table to define saturated mixing ration ! of water vapor for given temperature and pressure -! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K) -! DEW - dew in kg/m^2s -! SOILT - skin temperature (K) -! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! soilmois,tso - soil moisture (m^3/m^3) and temperature (k) +! dew - dew in kg/m^2s +! soilt - skin temperature (k) +! qsg,qvg,qcg - saturated mixing ratio, mixing ratio of ! water vapor and cloud at the ground ! surface, respectively (kg/kg) -! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of +! edir1, ec1, ett1, eeta - direct evaporation, evaporation of ! canopy water, transpiration in kg m-2 s-1 and total ! evaporation in m s-1. -! QFX, HFX - latent and sensible heat fluxes (W/m^2) -! S - soil heat flux in the top layer (W/m^2) -! RUNOFF - surface runoff (m/s) -! RUNOFF2 - underground runoff (m) -! MAVAIL - moisture availability in the top soil layer (0-1) -! INFILTRP - infiltration flux from the top of soil domain (m/s) +! qfx, hfx - latent and sensible heat fluxes (w/m^2) +! s - soil heat flux in the top layer (w/m^2) +! runoff - surface runoff (m/s) +! runoff2 - underground runoff (m) +! mavail - moisture availability in the top soil layer (0-1) +! infiltrp - infiltration flux from the top of soil domain (m/s) ! !***************************************************************** - IMPLICIT NONE + implicit none !----------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + integer, intent(in ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX - LOGICAL, INTENT(IN ) :: myj -!--- 3-D Atmospheric variables - REAL, & - INTENT(IN ) :: PATM, & - QVATM, & - QCATM -!--- 2-D variables - REAL, & - INTENT(IN ) :: GLW, & - GSW, & - GSWin, & - EMISS, & - RHO, & - PC, & - VEGFRAC, & + integer, intent(in ) :: i,j,iland,isoil + real, intent(in ) :: delt,conflx + logical, intent(in ) :: myj +!--- 3-d atmospheric variables + real, & + intent(in ) :: patm, & + qvatm, & + qcatm +!--- 2-d variables + real, & + intent(in ) :: glw, & + gsw, & + gswin, & + emiss, & + rho, & + pc, & + vegfrac, & lai, & infwater, & - QKMS, & - TKMS + qkms, & + tkms !--- soil properties - REAL, & - INTENT(IN ) :: RHOCS, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QMIN, & - QWRTZ, & - REF, & - WILT - - REAL, INTENT(IN ) :: CN, & - CW, & - KQWRTZ, & - KICE, & - KWT, & - XLV, & + real, & + intent(in ) :: rhocs, & + bclh, & + dqm, & + ksat, & + psis, & + qmin, & + qwrtz, & + ref, & + wilt + + real, intent(in ) :: cn, & + cw, & + kqwrtz, & + kice, & + kwt, & + xlv, & g0_p - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real, dimension(1:nzs), intent(in) :: zsmain, & + zshalf, & + dtdzs2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real, dimension(1:nddzs), intent(in) :: dtdzs - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real, dimension(1:5001), intent(in) :: tbq !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TSO, & - SOILMOIS, & - SMFRKEEP + real, dimension( 1:nzs ) , & + intent(inout) :: tso, & + soilmois, & + smfrkeep - REAL, DIMENSION(1:NZS), INTENT(IN) :: rstochcol - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: fieldcol_sf + real, dimension(1:nzs), intent(in) :: rstochcol + real, dimension(1:nzs), intent(inout) :: fieldcol_sf - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: KEEPFR + real, dimension( 1:nzs ) , & + intent(inout) :: keepfr !-------- 2-d variables - REAL, & - INTENT(INOUT) :: DEW, & - CST, & - DRIP, & - EDIR1, & - EC1, & - ETT1, & - EETA, & - EVAPL, & - PRCPL, & - MAVAIL, & - QVG, & - QSG, & - QCG, & - RNET, & - QFX, & - HFX, & - S, & - SAT, & - RUNOFF1, & - RUNOFF2, & - SOILT + real, & + intent(inout) :: dew, & + cst, & + drip, & + edir1, & + ec1, & + ett1, & + eeta, & + evapl, & + prcpl, & + mavail, & + qvg, & + qsg, & + qcg, & + rnet, & + qfx, & + hfx, & + s, & + sat, & + runoff1, & + runoff2, & + soilt !-------- 1-d variables - INTEGER , INTENT(IN) :: spp_lsm - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + integer , intent(in) :: spp_lsm + real, dimension(1:nzs), intent(out) :: soilice, & + soiliqw -!--- Local variables +!--- local variables - REAL :: INFILTRP, transum , & - RAINF, PRCPMS , & - TABS, T3, UPFLUX, XINET - REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real :: infiltrp, transum , & + rainf, prcpms , & + tabs, t3, upflux, xinet + real :: cp,rovcp,g0,lv,stbolt,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & - DD1,CMC2MS,DRYCAN,WETCAN , & - INFMAX,RIW, X - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + dd1,cmc2ms,drycan,wetcan , & + infmax,riw, x + real, dimension(1:nzs) :: transp,cap,diffu,hydro , & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: soiltold,smf - REAL :: soilres, alfa, fex, fex_fc, fc, psit + real :: soiltold,smf + real :: soilres, alfa, fex, fex_fc, fc, psit - INTEGER :: nzs1,nzs2,k + integer :: nzs1,nzs2,k !----------------------------------------------------------------- !-- define constants -! STBOLT=5.670151E-8 - RHOICE=900. - CI=RHOICE*2100. - XLMELT=3.35E+5 + rhoice=900. + ci=rhoice*2100. + xlmelt=3.35e+5 cvw=cw -! SAT=0.0004 prcpl=prcpms smf=0. @@ -2406,9 +2442,9 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & wetcan=0. drycan=1. -!--- Initializing local arrays - DO K=1,NZS - TRANSP (K)=0. +!--- initializing local arrays + do k=1,nzs + transp (k)=0. soilmoism(k)=0. soilice (k)=0. soiliqw (k)=0. @@ -2425,26 +2461,26 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & detal (k)=0. told (k)=0. smold (k)=0. - ENDDO + enddo - NZS1=NZS-1 - NZS2=NZS-2 + nzs1=nzs-1 + nzs2=nzs-2 dzstop=1./(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 + ras=rho*1.e-3 + riw=rhoice*1.e-3 -!--- Computation of volumetric content of ice in soil +!--- computation of volumetric content of ice in soil - DO K=1,NZS + do k=1,nzs !- main levels tln=log(tso(k)/273.15) if(tln.lt.0.) then - soiliqw(k)=(dqm+qmin)*(XLMELT* & + soiliqw(k)=(dqm+qmin)*(xlmelt* & (tso(k)-273.15)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) - soilice(k)=(soilmois(k)-soiliqw(k))/RIW + soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase if(keepfr(k).eq.1.) then @@ -2457,16 +2493,16 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & soiliqw(k)=soilmois(k) endif - ENDDO + enddo - DO K=1,NZS1 + do k=1,nzs1 !- middle of soil layers tav(k)=0.5*(tso(k)+tso(k+1)) soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) tavln=log(tav(k)/273.15) if(tavln.lt.0.) then - soiliqwm(k)=(dqm+qmin)*(XLMELT* & + soiliqwm(k)=(dqm+qmin)*(xlmelt* & (tav(k)-273.15)/tav(k)/9.81/psis) & **(-1./bclh)-qmin fwsat(k)=dqm-soiliqwm(k) @@ -2490,7 +2526,7 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & fwsat(k)=0. endif - ENDDO + enddo do k=1,nzs if(soilice(k).gt.0.) then @@ -2499,74 +2535,73 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & smfrkeep(k)=soilmois(k)/riw endif enddo - !****************************************************************** -! SOILPROP computes thermal diffusivity, and diffusional and +! soilprop computes thermal diffusivity, and diffusional and ! hydraulic condeuctivities !****************************************************************** - CALL SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & + call soilprop(spp_lsm,rstochcol,fieldcol_sf, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & + qwrtz,rhocs,dqm,qmin,psis,bclh,ksat, & !--- constants - riw,xlmelt,CP,G0_P,cvw,ci, & + riw,xlmelt,cp,g0_p,cvw,ci, & kqwrtz,kice,kwt, & !--- output variables thdif,diffu,hydro,cap) !******************************************************************** -!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW +!--- calculation of canopy water (Smirnova et al., 1996, eq.16) and dew -! DRIP=0. -! DD1=0. +! drip=0. +! dd1=0. - FQ=QKMS + fq=qkms - Q1=-QKMS*RAS*(QVATM - QSG) + q1=-qkms*ras*(qvatm - qsg) - DEW=0. - IF(QVATM.GE.QSG)THEN - DEW=FQ*(QVATM-QSG) - ENDIF + dew=0. + if(qvatm.ge.qsg)then + dew=fq*(qvatm-qsg) + endif -! IF(DEW.NE.0.)THEN -! DD1=CST+DELT*(PRCPMS +DEW*RAS) -! ELSE -! DD1=CST+ & -! DELT*(PRCPMS+RAS*FQ*(QVATM-QSG) & -! *(CST/SAT)**CN) -! ENDIF +! if(dew.ne.0.)then +! dd1=cst+delt*(prcpms +dew*ras) +! else +! dd1=cst+ & +! delt*(prcpms+ras*fq*(qvatm-qsg) & +! *(cst/sat)**cn) +! endif -! DD1=CST+DELT*PRCPMS +! dd1=cst+delt*prcpms -! IF(DD1.LT.0.) DD1=0. +! if(dd1.lt.0.) dd1=0. ! if(vegfrac.eq.0.)then ! cst=0. ! drip=0. ! endif -! IF (vegfrac.GT.0.) THEN -! CST=DD1 -! IF(CST.GT.SAT) THEN -! CST=SAT -! DRIP=DD1-SAT -! ENDIF -! ENDIF +! if (vegfrac.gt.0.) then +! cst=dd1 +! if(cst.gt.sat) then +! cst=sat +! drip=dd1-sat +! endif +! endif ! -!--- WETCAN is the fraction of vegetated area covered by canopy -!--- water, and DRYCAN is the fraction of vegetated area where +!--- wetcan is the fraction of vegetated area covered by canopy +!--- water, and drycan is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,max(0.,(CST/SAT))**CN) + wetcan=min(0.25,max(0.,(cst/sat))**cn) ! if(lai > 1.) wetcan=wetcan/lai - DRYCAN=1.-WETCAN + drycan=1.-wetcan !************************************************************** -! TRANSF computes transpiration function +! transf computes transpiration function !************************************************************** - CALL TRANSF(i,j, & + call transf(i,j, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -2575,21 +2610,21 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & tranf,transum) -!--- Save soil temp and moisture from the beginning of time step +!--- save soil temp and moisture from the beginning of time step do k=1,nzs told(k)=tso(k) smold(k)=soilmois(k) enddo -! Sakaguchi and Zeng (2009) - dry soil resistance to evaporation -! if (vgtype==11) then ! MODIS wetland +! sakaguchi and zeng (2009) - dry soil resistance to evaporation +! if (vgtype==11) then ! modis wetland alfa=1. ! else fex=min(1.,soilmois(1)/dqm) fex=max(fex,0.01) psit=psis*fex ** (-bclh) psit = max(-1.e5, psit) - alfa=min(1.,exp(g*psit/r_v/SOILT)) + alfa=min(1.,exp(g*psit/r_v/soilt)) ! endif alfa=1. ! field capacity @@ -2602,64 +2637,64 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & fex_fc=max(fex_fc,0.01) soilres=0.25*(1.-cos(piconst*fex_fc))**2. endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then ! if (i==421.and.j==280) then print *,'fex,psit,psis,bclh,g,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc', & fex,psit,psis,bclh,g,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc endif !************************************************************** -! SOILTEMP soilves heat budget and diffusion eqn. in soil +! soiltemp soilves heat budget and diffusion eqn. in soil !************************************************************** - CALL SOILTEMP( & + call soiltemp( & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF, & - PATM,TABS,QVATM,QCATM,EMISS,RNET, & - QKMS,TKMS,PC,rho,vegfrac, lai, & + prcpms,rainf, & + patm,tabs,qvatm,qcatm,emiss,rnet, & + qkms,tkms,pc,rho,vegfrac, lai, & thdif,cap,drycan,wetcan, & transum,dew,mavail,soilres,alfa, & !--- soil fixed fields - dqm,qmin,bclh,zsmain,zshalf,DTDZS,tbq, & + dqm,qmin,bclh,zsmain,zshalf,dtdzs,tbq, & !--- constants - xlv,CP,G0_P,cvw,stbolt, & + xlv,cp,g0_p,cvw,stbolt, & !--- output variables tso,soilt,qvg,qsg,qcg,x) !************************************************************************ -!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - ETT1=0. - DEW=0. +!--- calculation of dew using new value of qsg or transp if no dew + ett1=0. + dew=0. - IF(QVATM.GE.QSG)THEN - DEW=QKMS*(QVATM-QSG) - ETT1=0. - DO K=1,NZS - TRANSP(K)=0. - ENDDO - ELSE - - DO K=1,NROOT - TRANSP(K)=VEGFRAC*RAS*QKMS* & - (QVATM-QSG)* & - TRANF(K)*DRYCAN/ZSHALF(NROOT+1) - IF(TRANSP(K).GT.0.) TRANSP(K)=0. - ETT1=ETT1-TRANSP(K) - ENDDO - DO k=nroot+1,nzs + if(qvatm.ge.qsg)then + dew=qkms*(qvatm-qsg) + ett1=0. + do k=1,nzs transp(k)=0. enddo - ENDIF + else + + do k=1,nroot + transp(k)=vegfrac*ras*qkms* & + (qvatm-qsg)* & + tranf(k)*drycan/zshalf(nroot+1) + if(transp(k).gt.0.) transp(k)=0. + ett1=ett1-transp(k) + enddo + do k=nroot+1,nzs + transp(k)=0. + enddo + endif -!-- Recalculate volumetric content of frozen water in soil - DO K=1,NZS +!-- recalculate volumetric content of frozen water in soil + do k=1,nzs !- main levels tln=log(tso(k)/273.15) if(tln.lt.0.) then - soiliqw(k)=(dqm+qmin)*(XLMELT* & + soiliqw(k)=(dqm+qmin)*(xlmelt* & (tso(k)-273.15)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) @@ -2675,32 +2710,32 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & soilice(k)=0. soiliqw(k)=soilmois(k) endif - ENDDO + enddo !************************************************************************* -! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28) -! and Richards eqn. +! soilmoist solves moisture budget (Smirnova et al., 1996, eq.22,28) +! and richards eqn. !************************************************************************* - CALL SOILMOIST ( & + call soilmoist ( & !-- input - delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & + delt,nzs,nddzs,dtdzs,dtdzs2,riw, & zsmain,zshalf,diffu,hydro, & - QSG,QVG,QCG,QCATM,QVATM,-infwater, & - QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & + qsg,qvg,qcg,qcatm,qvatm,-infwater, & + qkms,transp,drip,dew,0.,soilice,vegfrac, & 0.,soilres, & !-- soil properties - DQM,QMIN,REF,KSAT,RAS,INFMAX, & + dqm,qmin,ref,ksat,ras,infmax, & !-- output - SOILMOIS,SOILIQW,MAVAIL,RUNOFF1, & - RUNOFF2,INFILTRP) + soilmois,soiliqw,mavail,runoff1, & + runoff2,infiltrp) -!--- KEEPFR is 1 when the temperature and moisture in soil -!--- are both increasing. In this case soil ice should not +!--- keepfr is 1 when the temperature and moisture in soil +!--- are both increasing. in this case soil ice should not !--- be increasing according to the freezing curve. -!--- Some part of ice is melted, but additional water is -!--- getting frozen. Thus, only structure of frozen soil is +!--- some part of ice is melted, but additional water is +!--- getting frozen. thus, only structure of frozen soil is !--- changed, and phase changes are not affecting the heat -!--- transfer. This situation may happen when it rains on the +!--- transfer. this situation may happen when it rains on the !--- frozen soil. do k=1,nzs @@ -2713,239 +2748,223 @@ SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf, & endif enddo -!--- THE DIAGNOSTICS OF SURFACE FLUXES +!--- the diagnostics of surface fluxes - T3 = STBOLT*SOILTold*SOILTold*SOILTold - UPFLUX = T3 * 0.5*(SOILTold+SOILT) - XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET - HFT=-TKMS*CP*RHO*(TABS-SOILT) - HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP - Q1=-QKMS*RAS*(QVATM - QSG) + t3 = stbolt*soiltold*soiltold*soiltold + upflux = t3 * 0.5*(soiltold+soilt) + xinet = emiss*(glw-upflux) + hft=-tkms*cp*rho*(tabs-soilt) + hfx=-tkms*cp*rho*(tabs-soilt) & + *(p1000mb*0.00001/patm)**rovcp + q1=-qkms*ras*(qvatm - qsg) - CMC2MS = 0. - IF (Q1.LE.0.) THEN + cmc2ms = 0. + if (q1.le.0.) then ! --- condensation - EC1=0. - EDIR1=0. - ETT1=0. + ec1=0. + edir1=0. + ett1=0. if(myj) then -!-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 - CST= CST-EETA*DELT*vegfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -!!! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then - print *,'Cond MYJ EETA',eeta,eeta*xlv, i,j - ENDIF +!-- moisture flux for coupling with myj pbl + eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3 + cst= cst-eeta*delt*vegfrac + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'cond myj eeta',eeta,eeta*xlv, i,j + endif else ! myj -!-- actual moisture flux from RUC LSM - EETA= - RHO*DEW - CST=CST+DELT*DEW*RAS * vegfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then -! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'Cond RUC LSM EETA',EETA,eeta*xlv, i,j - ENDIF +!-- actual moisture flux from ruc lsm + eeta= - rho*dew + cst=cst+delt*dew*ras * vegfrac + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'cond ruc lsm eeta',eeta,eeta*xlv, i,j + endif endif ! myj - QFX= XLV*EETA - EETA= - RHO*DEW - ELSE + qfx= xlv*eeta + eeta= - rho*dew + else ! --- evaporation - EDIR1 =-soilres*(1.-vegfrac)*QKMS*RAS* & - (QVATM-QVG) - CMC2MS=CST/DELT*RAS - EC1 = Q1 * WETCAN * vegfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'CST before update=',cst - print *,'EC1=',EC1,'CMC2MS=',CMC2MS - ENDIF -! ENDIF - - CST=max(0.,CST-EC1 * DELT) - -! if (EC1 > CMC2MS) then -! EC1 = min(cmc2ms,ec1) -! CST = 0. -! endif + edir1 =-soilres*(1.-vegfrac)*qkms*ras* & + (qvatm-qvg) + cmc2ms=cst/delt*ras + ec1 = q1 * wetcan * vegfrac + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'cst before update=',cst + print *,'ec1=',ec1,'cmc2ms=',cmc2ms + endif +! endif + + cst=max(0.,cst-ec1 * delt) if (myj) then -!-- moisture flux for coupling with MYJ PBL - EETA=-soilres*QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 +!-- moisture flux for coupling with myj pbl + eeta=-soilres*qkms*ras*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*1.e3 else ! myj - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG ', & - QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG - print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1 - print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN - print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras -! print *,'MYJ EETA',eeta,eeta*xlv - ENDIF -!-- actual moisture flux from RUC LSM - EETA = (EDIR1 + EC1 + ETT1)*1.E3 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then -! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'RUC LSM EETA',EETA,eeta*xlv - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'qkms,ras,qvatm/(1.+qvatm),qvg/(1.+qvg),qsg ', & + qkms,ras,qvatm/(1.+qvatm),qvg/(1.+qvg),qsg + print *,'q1*(1.-vegfrac),edir1',q1*(1.-vegfrac),edir1 + print *,'cst,wetcan,drycan',cst,wetcan,drycan + print *,'ec1=',ec1,'ett1=',ett1,'cmc2ms=',cmc2ms,'cmc2ms*ras=',cmc2ms*ras + endif +!-- actual moisture flux from ruc lsm + eeta = (edir1 + ec1 + ett1)*1.e3 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'ruc lsm eeta',eeta,eeta*xlv + endif endif ! myj - QFX= XLV * EETA - EETA = (EDIR1 + EC1 + ETT1)*1.E3 - ENDIF - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'potential temp HFT ',HFT - print *,'abs temp HFX ',HFX - ENDIF + qfx= xlv * eeta + eeta = (edir1 + ec1 + ett1)*1.e3 + endif + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'potential temp hft ',hft + print *,'abs temp hfx ',hfx + endif - EVAPL=EETA - S=THDIF(1)*CAP(1)*DZSTOP*(TSO(1)-TSO(2)) -! Energy budget - FLTOT=RNET-HFT-XLV*EETA-S-X - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'SOIL - FLTOT,RNET,HFT,QFX,S,X=',i,j,FLTOT,RNET,HFT,XLV*EETA,s,x + evapl=eeta + s=thdif(1)*cap(1)*dzstop*(tso(1)-tso(2)) +! energy budget + fltot=rnet-hft-xlv*eeta-s-x + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'soil - fltot,rnet,hft,qfx,s,x=',i,j,fltot,rnet,hft,xlv*eeta,s,x print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac',& edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac - ENDIF + endif if(detal(1) .ne. 0.) then -! SMF - energy of phase change in the first soil layer +! smf - energy of phase change in the first soil layer ! smf=xlmelt*1.e3*(soiliqwm(1)-soiliqwmold(1))/delt smf=fltot - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'detal(1),xlmelt,soiliqwm(1),delt',detal(1),xlmelt,soiliqwm(1),delt - print *,'Implicit phase change in the first layer - smf=',smf - ENDIF + print *,'implicit phase change in the first layer - smf=',smf + endif endif - 222 CONTINUE + 222 continue - 1123 FORMAT(I5,8F12.3) - 1133 FORMAT(I7,8E12.4) + 1123 format(i5,8f12.3) + 1133 format(i7,8e12.4) 123 format(i6,f6.2,7f8.1) - 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) + 122 format(1x,2i3,6f8.1,f8.3,f8.2) !------------------------------------------------------------------- - END SUBROUTINE SOIL + end subroutine soil !------------------------------------------------------------------- - SUBROUTINE SICE ( & + subroutine sice ( & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & - EMISS,RNET,QKMS,TKMS,rho,myj, & + prcpms,rainf,patm,qvatm,qcatm,glw,gsw, & + emiss,rnet,qkms,tkms,rho,myj, & !--- sea ice parameters tice,rhosice,capice,thdifice, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - xlv,CP,rovcp,cw,stbolt,tabs, & + xlv,cp,rovcp,cw,stbolt,tabs, & !--- output variables tso,dew,soilt,qvg,qsg,qcg, & - eeta,qfx,hfx,s,evapl,prcpl,fltot & + eeta,qfx,hfx,s,evapl,prcpl,fltot & ) !***************************************************************** -! Energy budget and heat diffusion eqns. for +! energy budget and heat diffusion eqns. for ! sea ice !************************************************************* - IMPLICIT NONE + implicit none !----------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + integer, intent(in ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX - LOGICAL, INTENT(IN ) :: myj -!--- 3-D Atmospheric variables - REAL, & - INTENT(IN ) :: PATM, & - QVATM, & - QCATM -!--- 2-D variables - REAL, & - INTENT(IN ) :: GLW, & - GSW, & - EMISS, & - RHO, & - QKMS, & - TKMS + integer, intent(in ) :: i,j,iland,isoil + real, intent(in ) :: delt,conflx + logical, intent(in ) :: myj +!--- 3-d atmospheric variables + real, & + intent(in ) :: patm, & + qvatm, & + qcatm +!--- 2-d variables + real, & + intent(in ) :: glw, & + gsw, & + emiss, & + rho, & + qkms, & + tkms !--- sea ice properties - REAL, DIMENSION(1:NZS) , & - INTENT(IN ) :: & + real, dimension(1:nzs) , & + intent(in ) :: & tice, & rhosice, & capice, & thdifice - REAL, INTENT(IN ) :: & - CW, & - XLV + real, intent(in ) :: & + cw, & + xlv - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real, dimension(1:nzs), intent(in) :: zsmain, & + zshalf, & + dtdzs2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real, dimension(1:nddzs), intent(in) :: dtdzs - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real, dimension(1:5001), intent(in) :: tbq !--- input/output variables !----soil temperature - REAL, DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO + real, dimension( 1:nzs ), intent(inout) :: tso !-------- 2-d variables - REAL, & - INTENT(INOUT) :: DEW, & - EETA, & - EVAPL, & - PRCPL, & - QVG, & - QSG, & - QCG, & - RNET, & - QFX, & - HFX, & - S, & - SOILT - -!--- Local variables - REAL :: x,x1,x2,x4,tn,denom - REAL :: RAINF, PRCPMS , & - TABS, T3, UPFLUX, XINET - - REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real, & + intent(inout) :: dew, & + eeta, & + evapl, & + prcpl, & + qvg, & + qsg, & + qcg, & + rnet, & + qfx, & + hfx, & + s, & + soilt + +!--- local variables + real :: x,x1,x2,x4,tn,denom + real :: rainf, prcpms , & + tabs, t3, upflux, xinet + + real :: cp,rovcp,g0,lv,stbolt,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & - PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & - TDENOM,QGOLD,SNOH + real :: fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11 , & + pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2 , & + tdenom,qgold,snoh - REAL :: AA1,RHCS, icemelt + real :: aa1,rhcs, icemelt - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real, dimension(1:nzs) :: cotso,rhtso - INTEGER :: nzs1,nzs2,k,k1,kn,kk + integer :: nzs1,nzs2,k,k1,kn,kk !----------------------------------------------------------------- !-- define constants -! STBOLT=5.670151E-8 - XLMELT=3.35E+5 + xlmelt=3.35e+5 cvw=cw prcpl=prcpms - NZS1=NZS-1 - NZS2=NZS-2 + nzs1=nzs-1 + nzs2=nzs-2 dzstop=1./(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3 + ras=rho*1.e-3 do k=1,nzs cotso(k)=0. @@ -2953,450 +2972,439 @@ SUBROUTINE SICE ( & enddo cotso(1)=0. - rhtso(1)=TSO(NZS) - - DO 33 K=1,NZS2 - KN=NZS-K - K1=2*KN-3 - X1=DTDZS(K1)*THDIFICE(KN-1) - X2=DTDZS(K1+1)*THDIFICE(KN) - FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & - -X2*(TSO(KN)-TSO(KN+1)) - DENOM=1.+X1+X2-X2*cotso(K) - cotso(K+1)=X1/DENOM - rhtso(K+1)=(FT+X2*rhtso(K))/DENOM - 33 CONTINUE + rhtso(1)=tso(nzs) + + do 33 k=1,nzs2 + kn=nzs-k + k1=2*kn-3 + x1=dtdzs(k1)*thdifice(kn-1) + x2=dtdzs(k1+1)*thdifice(kn) + ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) & + -x2*(tso(kn)-tso(kn+1)) + denom=1.+x1+x2-x2*cotso(k) + cotso(k+1)=x1/denom + rhtso(k+1)=(ft+x2*rhtso(k))/denom + 33 continue !************************************************************************ -!--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26) - RHCS=CAPICE(1) - H=1. - FKT=TKMS - D1=cotso(NZS1) - D2=rhtso(NZS1) - TN=SOILT - D9=THDIFICE(1)*RHCS*dzstop - D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT - R21=R211*CP*RHO - R22=.5/(THDIFICE(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 - R7=R6/TN - D11=RNET+R6 - TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & - +RAINF*CVW*PRCPMS - FKQ=QKMS*RHO - R210=R211*RHO - AA=XLS*(FKQ+R210)/TDENOM - BB=(D10*TABS+R21*TN+XLS*(QVATM*FKQ & - +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - )/TDENOM - AA1=AA - PP=PATM*1.E3 - AA1=AA1/PP - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - PRINT *,' VILKA-SEAICE1' - print *,'D10,TABS,R21,TN,QVATM,FKQ', & - D10,TABS,R21,TN,QVATM,FKQ - print *,'RNET, EMISS, STBOLT, SOILT',RNET, EMISS, STBOLT, SOILT - print *,'R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM', & - R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM +!--- the heat balance equation (Smirnova et al., 1996, eq. 21,26) + rhcs=capice(1) + h=1. + fkt=tkms + d1=cotso(nzs1) + d2=rhtso(nzs1) + tn=soilt + d9=thdifice(1)*rhcs*dzstop + d10=tkms*cp*rho + r211=.5*conflx/delt + r21=r211*cp*rho + r22=.5/(thdifice(1)*delt*dzstop**2) + r6=emiss *stbolt*.5*tn**4 + r7=r6/tn + d11=rnet+r6 + tdenom=d9*(1.-d1+r22)+d10+r21+r7 & + +rainf*cvw*prcpms + fkq=qkms*rho + r210=r211*rho + aa=xls*(fkq+r210)/tdenom + bb=(d10*tabs+r21*tn+xls*(qvatm*fkq & + +r210*qvg)+d11+d9*(d2+r22*tn) & + +rainf*cvw*prcpms*max(273.15,tabs) & + )/tdenom + aa1=aa + pp=patm*1.e3 + aa1=aa1/pp + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' vilka-seaice1' + print *,'d10,tabs,r21,tn,qvatm,fkq', & + d10,tabs,r21,tn,qvatm,fkq + print *,'rnet, emiss, stbolt, soilt',rnet, emiss, stbolt, soilt + print *,'r210,qvg,d11,d9,d2,r22,rainf,cvw,prcpms,tdenom', & + r210,qvg,d11,d9,d2,r22,rainf,cvw,prcpms,tdenom print *,'tn,aa1,bb,pp,fkq,r210', & tn,aa1,bb,pp,fkq,r210 - ENDIF - QGOLD=QSG - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + endif + qgold=qsg + call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil) !--- it is saturation over sea ice - QVG=QS1 - QSG=QS1 - TSO(1)=min(271.4,TS1) - QCG=0. + qvg=qs1 + qsg=qs1 + tso(1)=min(271.4,ts1) + qcg=0. !--- sea ice melting is not included in this simple approach -!--- SOILT - skin temperature - SOILT=TSO(1) -!---- Final solution for soil temperature - TSO - DO K=2,NZS - KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) - END DO -!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - DEW=0. - -!--- THE DIAGNOSTICS OF SURFACE FLUXES - T3 = STBOLT*TN*TN*TN - UPFLUX = T3 *0.5*(TN+SOILT) - XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET - HFT=-TKMS*CP*RHO*(TABS-SOILT) - HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP - Q1=-QKMS*RAS*(QVATM - QSG) - IF (Q1.LE.0.) THEN +!--- soilt - skin temperature + soilt=tso(1) +!---- final solution for soil temperature - tso + do k=2,nzs + kk=nzs-k+1 + tso(k)=min(271.4,rhtso(kk)+cotso(kk)*tso(k-1)) + end do +!--- calculation of dew using new value of qsg or transp if no dew + dew=0. + +!--- the diagnostics of surface fluxes + t3 = stbolt*tn*tn*tn + upflux = t3 *0.5*(tn+soilt) + xinet = emiss*(glw-upflux) + hft=-tkms*cp*rho*(tabs-soilt) + hfx=-tkms*cp*rho*(tabs-soilt) & + *(p1000mb*0.00001/patm)**rovcp + q1=-qkms*ras*(qvatm - qsg) + if (q1.le.0.) then ! --- condensation if(myj) then -!-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'MYJ EETA',eeta - ENDIF +!-- moisture flux for coupling with myj pbl + eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'myj eeta',eeta + endif else ! myj -!-- actual moisture flux from RUC LSM - DEW=QKMS*(QVATM-QSG) - EETA= - RHO*DEW - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'RUC LSM EETA',eeta - ENDIF +!-- actual moisture flux from ruc lsm + dew=qkms*(qvatm-qsg) + eeta= - rho*dew + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'ruc lsm eeta',eeta + endif endif ! myj - QFX= XLS*EETA - EETA= - RHO*DEW - ELSE + qfx= xls*eeta + eeta= - rho*dew + else ! --- evaporation if(myj) then -!-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'MYJ EETA',eeta - ENDIF +!-- moisture flux for coupling with myj pbl + eeta=-qkms*ras*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*1.e3 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'myj eeta',eeta + endif else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ -!-- actual moisture flux from RUC LSM - EETA = Q1*1.E3 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'RUC LSM EETA',eeta - ENDIF +!-- actual moisture flux from ruc lsm + eeta = q1*1.e3 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'ruc lsm eeta',eeta + endif endif ! myj - QFX= XLS * EETA - EETA = Q1*1.E3 - ENDIF - EVAPL=EETA + qfx= xls * eeta + eeta = q1*1.e3 + endif + evapl=eeta - S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2)) + s=thdifice(1)*capice(1)*dzstop*(tso(1)-tso(2)) ! heat storage in surface layer - SNOH=0. -! There is ice melt - X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & - XLS*rho*r211*(QSG-QGOLD) - X=X & + snoh=0. +! there is ice melt + x= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn) + & + xls*rho*r211*(qsg-qgold) + x=x & ! "heat" from rain - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -rainf*cvw*prcpms*(max(273.15,tabs)-soilt) !-- excess energy spent on sea ice melt - icemelt=RNET-XLS*EETA -HFT -S -X - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + icemelt=rnet-xls*eeta -hft -s -x + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'icemelt=',icemelt - ENDIF + endif - FLTOT=RNET-XLS*EETA-HFT-S-X-icemelt - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SICE - FLTOT,RNET,HFT,QFX,S,SNOH,X=', & - FLTOT,RNET,HFT,XLS*EETA,s,icemelt,X - ENDIF + fltot=rnet-xls*eeta-hft-s-x-icemelt + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'sice - fltot,rnet,hft,qfx,s,snoh,x=', & + fltot,rnet,hft,xls*eeta,s,icemelt,x + endif !------------------------------------------------------------------- - END SUBROUTINE SICE + end subroutine sice !------------------------------------------------------------------- - SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& + subroutine snowsoil (spp_lsm,rstochcol,fieldcol_sf,& !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - meltfactor,rhonewsn,SNHEI_CRIT, & ! new - ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & - RHOSN, & - PATM,QVATM,QCATM, & - GLW,GSW,GSWin,EMISS,RNET,IVGTYP, & - QKMS,TKMS,PC,cst,drip,infwater, & + meltfactor,rhonewsn,snhei_crit, & ! new + iland,prcpms,rainf,newsnow,snhei,snwe,snowfrac, & + rhosn, & + patm,qvatm,qcatm, & + glw,gsw,gswin,emiss,rnet,ivgtyp, & + qkms,tkms,pc,cst,drip,infwater, & rho,vegfrac,alb,znt,lai, & - MYJ, & + myj, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - xlv,CP,rovcp,G0_P,cw,stbolt,TABS, & - KQWRTZ,KICE,KWT, & + xlv,cp,rovcp,g0_p,cw,stbolt,tabs, & + kqwrtz,kice,kwt, & !--- output variables ilnb,snweprint,snheiprint,rsm, & soilmois,tso,smfrkeep,keepfr, & dew,soilt,soilt1,tsnav, & - qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & + qvg,qsg,qcg,smelt,snoh,snflx,snom, & edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & prcpl,fltot,runoff1,runoff2,mavail,soilice, & soiliqw,infiltrp ) !*************************************************************** -! Energy and moisture budget for snow, heat diffusion eqns. -! in snow and soil, Richards eqn. for soil covered with snow +! energy and moisture budget for snow, heat diffusion eqns. +! in snow and soil, richards eqn. for soil covered with snow ! -! DELT - time step (s) +! delt - time step (s) ! ktau - numver of time step -! CONFLX - depth of constant flux layer (m) -! J,I - the location of grid point -! IME, JME, NZS - dimensions of the domain -! NROOT - number of levels within the root zone -! PRCPMS - precipitation rate in m/s -! NEWSNOW - pcpn in soilid form (m) -! SNHEI, SNWE - snow height and snow water equivalent (m) -! RHOSN - snow density (kg/m-3) -! PATM - pressure (bar) -! QVATM,QCATM - cloud and water vapor mixing ratio +! conflx - depth of constant flux layer (m) +! j,i - the location of grid point +! ime, jme, nzs - dimensions of the domain +! nroot - number of levels within the root zone +! prcpms - precipitation rate in m/s +! newsnow - pcpn in soilid form (m) +! snhei, snwe - snow height and snow water equivalent (m) +! rhosn - snow density (kg/m-3) +! patm - pressure (bar) +! qvatm,qcatm - cloud and water vapor mixing ratio ! at the first atm. level (kg/kg) -! GLW, GSW - incoming longwave and absorbed shortwave -! radiation at the surface (W/m^2) -! EMISS,RNET - emissivity (0-1) of the ground surface and net -! radiation at the surface (W/m^2) -! QKMS - exchange coefficient for water vapor in the +! glw, gsw - incoming longwave and absorbed shortwave +! radiation at the surface (w/m^2) +! emiss,rnet - emissivity (0-1) of the ground surface and net +! radiation at the surface (w/m^2) +! qkms - exchange coefficient for water vapor in the ! surface layer (m/s) -! TKMS - exchange coefficient for heat in the surface +! tkms - exchange coefficient for heat in the surface ! layer (m/s) -! PC - plant coefficient (resistance) (0-1) -! RHO - density of atmosphere near surface (kg/m^3) -! VEGFRAC - greeness fraction (0-1) -! RHOCS - volumetric heat capacity of dry soil (J/m^3/K) -! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3) -! REF, WILT - field capacity soil moisture and the +! pc - plant coefficient (resistance) (0-1) +! rho - density of atmosphere near surface (kg/m^3) +! vegfrac - greeness fraction (0-1) +! rhocs - volumetric heat capacity of dry soil (j/m^3/k) +! dqm, qmin - porosity minus residual soil moisture qmin (m^3/m^3) +! ref, wilt - field capacity soil moisture and the ! wilting point (m^3/m^3) -! PSIS - matrix potential at saturation (m) -! BCLH - exponent for Clapp-Hornberger parameterization -! KSAT - saturated hydraulic conductivity (m/s) -! SAT - maximum value of water intercepted by canopy (m) -! CN - exponent for calculation of canopy water -! ZSMAIN - main levels in soil (m) -! ZSHALF - middle of the soil layers (m) -! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil -! TBQ - table to define saturated mixing ration +! psis - matrix potential at saturation (m) +! bclh - exponent for clapp-hornberger parameterization +! ksat - saturated hydraulic conductivity (m/s) +! sat - maximum value of water intercepted by canopy (m) +! cn - exponent for calculation of canopy water +! zsmain - main levels in soil (m) +! zshalf - middle of the soil layers (m) +! dtdzs,dtdzs2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil +! tbq - table to define saturated mixing ration ! of water vapor for given temperature and pressure ! ilnb - number of layers in snow ! rsm - liquid water inside snow pack (m) -! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K) -! DEW - dew in (kg/m^2 s) -! SOILT - skin temperature (K) -! SOILT1 - snow temperature at 7.5 cm depth (K) -! TSNAV - average temperature of snow pack (C) -! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! soilmois,tso - soil moisture (m^3/m^3) and temperature (k) +! dew - dew in (kg/m^2 s) +! soilt - skin temperature (k) +! soilt1 - snow temperature at 7.5 cm depth (k) +! tsnav - average temperature of snow pack (c) +! qsg,qvg,qcg - saturated mixing ratio, mixing ratio of ! water vapor and cloud at the ground ! surface, respectively (kg/kg) -! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of +! edir1, ec1, ett1, eeta - direct evaporation, evaporation of ! canopy water, transpiration (kg m-2 s-1) and total ! evaporation in (m s-1). -! QFX, HFX - latent and sensible heat fluxes (W/m^2) -! S - soil heat flux in the top layer (W/m^2) -! SUBLIM - snow sublimation (kg/m^2/s) -! RUNOFF1 - surface runoff (m/s) -! RUNOFF2 - underground runoff (m) -! MAVAIL - moisture availability in the top soil layer (0-1) -! SOILICE - content of soil ice in soil layers (m^3/m^3) -! SOILIQW - lliquid water in soil layers (m^3/m^3) -! INFILTRP - infiltration flux from the top of soil domain (m/s) -! XINET - net long-wave radiation (W/m^2) +! qfx, hfx - latent and sensible heat fluxes (w/m^2) +! s - soil heat flux in the top layer (w/m^2) +! sublim - snow sublimation (kg/m^2/s) +! runoff1 - surface runoff (m/s) +! runoff2 - underground runoff (m) +! mavail - moisture availability in the top soil layer (0-1) +! soilice - content of soil ice in soil layers (m^3/m^3) +! soiliqw - lliquid water in soil layers (m^3/m^3) +! infiltrp - infiltration flux from the top of soil domain (m/s) +! xinet - net long-wave radiation (w/m^2) ! !******************************************************************* - IMPLICIT NONE + implicit none !------------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + integer, intent(in ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil - - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & - RAINF,NEWSNOW,RHONEWSN, & - SNHEI_CRIT,meltfactor - - LOGICAL, INTENT(IN ) :: myj - -!--- 3-D Atmospheric variables - REAL, & - INTENT(IN ) :: PATM, & - QVATM, & - QCATM -!--- 2-D variables - REAL , & - INTENT(IN ) :: GLW, & - GSW, & - GSWin, & - RHO, & - PC, & - VEGFRAC, & + integer, intent(in ) :: i,j,isoil + + real, intent(in ) :: delt,conflx,prcpms , & + rainf,newsnow,rhonewsn, & + snhei_crit,meltfactor + + logical, intent(in ) :: myj + +!--- 3-d atmospheric variables + real, & + intent(in ) :: patm, & + qvatm, & + qcatm +!--- 2-d variables + real , & + intent(in ) :: glw, & + gsw, & + gswin, & + rho, & + pc, & + vegfrac, & lai, & infwater, & - QKMS, & - TKMS + qkms, & + tkms - INTEGER, INTENT(IN ) :: IVGTYP + integer, intent(in ) :: ivgtyp !--- soil properties - REAL , & - INTENT(IN ) :: RHOCS, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QMIN, & - QWRTZ, & - REF, & - SAT, & - WILT - - REAL, INTENT(IN ) :: CN, & - CW, & - XLV, & - G0_P, & - KQWRTZ, & - KICE, & - KWT - - - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 - - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ - - REAL, DIMENSION(1:NZS), INTENT(IN) :: rstochcol - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: fieldcol_sf + real , & + intent(in ) :: rhocs, & + bclh, & + dqm, & + ksat, & + psis, & + qmin, & + qwrtz, & + ref, & + sat, & + wilt + + real, intent(in ) :: cn, & + cw, & + xlv, & + g0_p, & + kqwrtz, & + kice, & + kwt + + + real, dimension(1:nzs), intent(in) :: zsmain, & + zshalf, & + dtdzs2 + + real, dimension(1:nddzs), intent(in) :: dtdzs + + real, dimension(1:5001), intent(in) :: tbq + + real, dimension(1:nzs), intent(in) :: rstochcol + real, dimension(1:nzs), intent(inout) :: fieldcol_sf !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TSO, & - SOILMOIS, & - SMFRKEEP + real, dimension( 1:nzs ) , & + intent(inout) :: tso, & + soilmois, & + smfrkeep - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: KEEPFR + real, dimension( 1:nzs ) , & + intent(inout) :: keepfr - INTEGER, INTENT(INOUT) :: ILAND + integer, intent(inout) :: iland !-------- 2-d variables - REAL , & - INTENT(INOUT) :: DEW, & - CST, & - DRIP, & - EDIR1, & - EC1, & - ETT1, & - EETA, & - RHOSN, & - SUBLIM, & - PRCPL, & - ALB, & - EMISS, & - ZNT, & - MAVAIL, & - QVG, & - QSG, & - QCG, & - QFX, & - HFX, & - S, & - RUNOFF1, & - RUNOFF2, & - SNWE, & - SNHEI, & - SMELT, & - SNOM, & - SNOH, & - SNFLX, & - SOILT, & - SOILT1, & - SNOWFRAC, & - TSNAV - - INTEGER, INTENT(INOUT) :: ILNB + real , & + intent(inout) :: dew, & + cst, & + drip, & + edir1, & + ec1, & + ett1, & + eeta, & + rhosn, & + sublim, & + prcpl, & + alb, & + emiss, & + znt, & + mavail, & + qvg, & + qsg, & + qcg, & + qfx, & + hfx, & + s, & + runoff1, & + runoff2, & + snwe, & + snhei, & + smelt, & + snom, & + snoh, & + snflx, & + soilt, & + soilt1, & + snowfrac, & + tsnav + + integer, intent(inout) :: ilnb !-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + real, dimension(1:nzs), intent(out) :: soilice, & + soiliqw - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT - INTEGER, INTENT(IN) :: spp_lsm -!--- Local variables + real, intent(out) :: rsm, & + snweprint, & + snheiprint + integer, intent(in) :: spp_lsm +!--- local variables - INTEGER :: nzs1,nzs2,k + integer :: nzs1,nzs2,k - REAL :: INFILTRP, TRANSUM , & - SNTH, NEWSN , & - TABS, T3, UPFLUX, XINET , & - BETA, SNWEPR,EPDT,PP - REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop , & + real :: infiltrp, transum , & + snth, newsn , & + tabs, t3, upflux, xinet , & + beta, snwepr,epdt,pp + real :: cp,rovcp,g0,lv,xlvm,stbolt,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & - DD1,CMC2MS,DRYCAN,WETCAN , & - INFMAX,RIW,DELTSN,H,UMVEG + dd1,cmc2ms,drycan,wetcan , & + infmax,riw,deltsn,h,umveg - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + real, dimension(1:nzs) :: transp,cap,diffu,hydro , & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: soiltold, qgold + real :: soiltold, qgold - REAL :: RNET, X + real :: rnet, x !----------------------------------------------------------------- cvw=cw - XLMELT=3.35E+5 + xlmelt=3.35e+5 !-- heat of water vapor sublimation - XLVm=XLV+XLMELT -! STBOLT=5.670151E-8 - -!--- SNOW flag -- ISICE -! ILAND=isice - -!--- DELTSN - is the threshold for splitting the snow layer into 2 layers. -!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, -!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is -!--- computed using SNWE=0.03 m and current snow density. -!--- SNTH - the threshold below which the snow layer is combined with -!--- the top soil layer. SNTH is computed using snwe=0.016 m, and + xlvm=xlv+xlmelt + +!--- snow flag -- isice +! iland=isice + +!--- deltsn - is the threshold for splitting the snow layer into 2 layers. +!--- with snow density 400 kg/m^3, this threshold is equal to 7.5 cm, +!--- equivalent to 0.03 m snwe. for other snow densities the threshold is +!--- computed using snwe=0.03 m and current snow density. +!--- snth - the threshold below which the snow layer is combined with +!--- the top soil layer. snth is computed using snwe=0.016 m, and !--- equals 4 cm for snow density 400 kg/m^3. -!save SOILT and QVG +!save soilt and qvg soiltold=soilt qgold=qvg x=0. -! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE -! DELTSN=5.*SNHEI_CRIT -! snth=0.4*SNHEI_CRIT - - DELTSN=0.05*1.e3/rhosn + deltsn=0.05*1.e3/rhosn snth=0.01*1.e3/rhosn -! snth=0.01601*1.e3/rhosn - -! if(i.eq.442.and.j.eq.260) then ! print *,'deltsn,snhei,snth',i,j,deltsn,snhei,snth -! ENDIF -! For 2-layer snow model when the snow depth is marginally higher than DELTSN, -! reset DELTSN to half of snow depth. - IF(SNHEI.GE.DELTSN+SNTH) THEN +! for 2-layer snow model when the snow depth is marginally higher than deltsn, +! reset deltsn to half of snow depth. + if(snhei.ge.deltsn+snth) then if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth - ENDIF - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'deltsn is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth + endif + endif - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 -! MAVAIL=1. - RSM=0. + rhoice=900. + ci=rhoice*2100. + ras=rho*1.e-3 + riw=rhoice*1.e-3 + rsm=0. - DO K=1,NZS - TRANSP (K)=0. + do k=1,nzs + transp (k)=0. soilmoism (k)=0. soiliqwm (k)=0. soilice (k)=0. @@ -3412,30 +3420,30 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& detal (k)=0. told (k)=0. smold (k)=0. - ENDDO + enddo snweprint=0. snheiprint=0. prcpl=prcpms -!*** DELTSN is the depth of the top layer of snow where +!*** deltsn is the depth of the top layer of snow where !*** there is a temperature gradient, the rest of the snow layer !*** is considered to have constant temperature - NZS1=NZS-1 - NZS2=NZS-2 - DZSTOP=1./(zsmain(2)-zsmain(1)) + nzs1=nzs-1 + nzs2=nzs-2 + dzstop=1./(zsmain(2)-zsmain(1)) -!----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND --- -!----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) --- +!----- the calculation of thermal diffusivity, diffusional and --- +!----- hydraulic conductivity (Smirnova et al. 1996, eq.2,5,6) --- !tgs - the following loop is added to define the amount of frozen !tgs - water in soil if there is any - DO K=1,NZS + do k=1,nzs tln=log(tso(k)/273.15) if(tln.lt.0.) then - soiliqw(k)=(dqm+qmin)*(XLMELT* & + soiliqw(k)=(dqm+qmin)*(xlmelt* & (tso(k)-273.15)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) @@ -3453,16 +3461,16 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& soiliqw(k)=soilmois(k) endif - ENDDO + enddo - DO K=1,NZS1 + do k=1,nzs1 tav(k)=0.5*(tso(k)+tso(k+1)) soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) tavln=log(tav(k)/273.15) if(tavln.lt.0.) then - soiliqwm(k)=(dqm+qmin)*(XLMELT* & + soiliqwm(k)=(dqm+qmin)*(xlmelt* & (tav(k)-273.15)/tav(k)/9.81/psis) & **(-1./bclh)-qmin fwsat(k)=dqm-soiliqwm(k) @@ -3486,7 +3494,7 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& fwsat(k)=0. endif - ENDDO + enddo do k=1,nzs if(soilice(k).gt.0.) then @@ -3495,63 +3503,60 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& smfrkeep(k)=soilmois(k)/riw endif enddo - !****************************************************************** -! SOILPROP computes thermal diffusivity, and diffusional and +! soilprop computes thermal diffusivity, and diffusional and ! hydraulic condeuctivities !****************************************************************** - CALL SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & + call soilprop(spp_lsm,rstochcol,fieldcol_sf, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & + qwrtz,rhocs,dqm,qmin,psis,bclh,ksat, & !--- constants - riw,xlmelt,CP,G0_P,cvw,ci, & + riw,xlmelt,cp,g0_p,cvw,ci, & kqwrtz,kice,kwt, & !--- output variables thdif,diffu,hydro,cap) !******************************************************************** -!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW +!--- calculation of canopy water (Smirnova et al., 1996, eq.16) and dew -! DRIP=0. - SMELT=0. -! DD1=0. - H=1. + smelt=0. + h=mavail - FQ=QKMS + fq=qkms -!--- If vegfrac.ne.0. then part of falling snow can be +!--- if vegfrac.ne.0. then part of falling snow can be !--- intercepted by the canopy. - DEW=0. - UMVEG=1.-vegfrac - EPOT = -FQ*(QVATM-QSG) + dew=0. + umveg=1.-vegfrac + epot = -fq*(qvatm-qsg) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst - ENDIF - SNWEPR=SNWE - -! check if all snow can evaporate during DT - BETA=1. - EPDT = EPOT * RAS *DELT*UMVEG - IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) - SNWE=0. - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snwe after subtracting intercepted snow - snwe=',snwe,vegfrac,cst + endif + snwepr=snwe + +! check if all snow can evaporate during dt + beta=1. + epdt = epot * ras *delt*umveg + if(epdt.gt.0. .and. snwepr.le.epdt) then + beta=snwepr/max(1.e-8,epdt) + snwe=0. + endif - WETCAN=min(0.25,max(0.,(CST/SAT))**CN) + wetcan=min(0.25,max(0.,(cst/sat))**cn) ! if(lai > 1.) wetcan=wetcan/lai - DRYCAN=1.-WETCAN + drycan=1.-wetcan !************************************************************** -! TRANSF computes transpiration function +! transf computes transpiration function !************************************************************** - CALL TRANSF(i,j, & + call transf(i,j, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -3559,73 +3564,72 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& !--- output variables tranf,transum) -!--- Save soil temp and moisture from the beginning of time step +!--- save soil temp and moisture from the beginning of time step do k=1,nzs told(k)=tso(k) smold(k)=soilmois(k) enddo !************************************************************** -! SNOWTEMP solves heat budget and diffusion eqn. in soil +! snowtemp solves heat budget and diffusion eqn. in soil !************************************************************** - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print *, 'TSO before calling SNOWTEMP: ', tso - ENDIF - CALL SNOWTEMP( & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then +print *, 'tso before calling snowtemp: ', tso + endif + call snowtemp( & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & snwe,snwepr,snhei,newsnow,snowfrac, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor - PRCPMS,RAINF, & - PATM,TABS,QVATM,QCATM, & - GLW,GSW,EMISS,RNET, & - QKMS,TKMS,PC,rho,vegfrac, & + prcpms,rainf, & + patm,tabs,qvatm,qcatm, & + glw,gsw,emiss,rnet, & + qkms,tkms,pc,rho,vegfrac, & thdif,cap,drycan,wetcan,cst, & tranf,transum,dew,mavail, & !--- soil fixed fields dqm,qmin,psis,bclh, & - zsmain,zshalf,DTDZS,tbq, & + zsmain,zshalf,dtdzs,tbq, & !--- constants - xlvm,CP,rovcp,G0_P,cvw,stbolt, & + xlvm,cp,rovcp,g0_p,cvw,stbolt, & !--- output variables snweprint,snheiprint,rsm, & tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & smelt,snoh,snflx,s,ilnb,x) !************************************************************************ -!--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - DEW=0. - ETT1=0. - PP=PATM*1.E3 - EPOT = -FQ*(QVATM-QSG) - IF(EPOT.GT.0.) THEN -! Evaporation - DO K=1,NROOT - TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & - *tranf(K)*DRYCAN/zshalf(NROOT+1) -! IF(TRANSP(K).GT.0.) TRANSP(K)=0. - ETT1=ETT1-TRANSP(K) - ENDDO - DO k=nroot+1,nzs +!--- recalculation of dew using new value of qsg or transp if no dew + dew=0. + ett1=0. + pp=patm*1.e3 + epot = -fq*(qvatm-qsg) + if(epot.gt.0.) then +! evaporation + do k=1,nroot + transp(k)=vegfrac*ras*fq*(qvatm-qsg) & + *tranf(k)*drycan/zshalf(nroot+1) + ett1=ett1-transp(k) + enddo + do k=nroot+1,nzs transp(k)=0. enddo - ELSE -! Sublimation - DEW=-EPOT - DO K=1,NZS - TRANSP(K)=0. - ENDDO - ETT1=0. - ENDIF + else +! sublimation + dew=-epot + do k=1,nzs + transp(k)=0. + enddo + ett1=0. + endif !-- recalculating of frozen water in soil - DO K=1,NZS + do k=1,nzs tln=log(tso(k)/273.15) if(tln.lt.0.) then - soiliqw(k)=(dqm+qmin)*(XLMELT* & + soiliqw(k)=(dqm+qmin)*(xlmelt* & (tso(k)-273.15)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) @@ -3641,44 +3645,44 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& soilice(k)=0. soiliqw(k)=soilmois(k) endif - ENDDO + enddo !************************************************************************* -!--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) -! AND TSO,ETA PROFILES +!--- tqcan for solution of moisture balance (Smirnova et al. 1996, eq.22,28) +! and tso,eta profiles !************************************************************************* - CALL SOILMOIST ( & + call soilmoist ( & !-- input - delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & + delt,nzs,nddzs,dtdzs,dtdzs2,riw, & zsmain,zshalf,diffu,hydro, & - QSG,QVG,QCG,QCATM,QVATM,-INFWATER, & - QKMS,TRANSP,0., & - 0.,SMELT,soilice,vegfrac, & + qsg,qvg,qcg,qcatm,qvatm,-infwater, & + qkms,transp,0., & + 0.,smelt,soilice,vegfrac, & snowfrac,1., & !-- soil properties - DQM,QMIN,REF,KSAT,RAS,INFMAX, & + dqm,qmin,ref,ksat,ras,infmax, & !-- output - SOILMOIS,SOILIQW,MAVAIL,RUNOFF1, & - RUNOFF2,infiltrp) + soilmois,soiliqw,mavail,runoff1, & + runoff2,infiltrp) ! endif -!-- Restore land-use parameters if all snow is melted - IF(SNHEI.EQ.0.) then +!-- restore land-use parameters if all snow is melted + if(snhei.eq.0.) then tsnav=soilt-273.15 - ENDIF + endif ! 21apr2009 -! SNOM [mm] goes into the passed-in ACSNOM variable in the grid derived type - SNOM=SNOM+SMELT*DELT*1.e3 +! snom [mm] goes into the passed-in acsnom variable in the grid derived type + snom=snom+smelt*delt*1.e3 ! -!--- KEEPFR is 1 when the temperature and moisture in soil -!--- are both increasing. In this case soil ice should not +!--- keepfr is 1 when the temperature and moisture in soil +!--- are both increasing. in this case soil ice should not !--- be increasing according to the freezing curve. -!--- Some part of ice is melted, but additional water is -!--- getting frozen. Thus, only structure of frozen soil is +!--- some part of ice is melted, but additional water is +!--- getting frozen. thus, only structure of frozen soil is !--- changed, and phase changes are not affecting the heat -!--- transfer. This situation may happen when it rains on the +!--- transfer. this situation may happen when it rains on the !--- frozen soil. do k=1,nzs @@ -3690,570 +3694,557 @@ SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,& endif endif enddo -!--- THE DIAGNOSTICS OF SURFACE FLUXES - - T3 = STBOLT*SOILTold*SOILTold*SOILTold - UPFLUX = T3 *0.5*(SOILTold+SOILT) - XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET - HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'potential temp HFX',hfx - ENDIF - HFT=-TKMS*CP*RHO*(TABS-SOILT) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'abs temp HFX',hft - ENDIF - Q1 = - FQ*RAS* (QVATM - QSG) - CMC2MS=0. - IF (Q1.LT.0.) THEN +!--- the diagnostics of surface fluxes + + t3 = stbolt*soiltold*soiltold*soiltold + upflux = t3 *0.5*(soiltold+soilt) + xinet = emiss*(glw-upflux) + hfx=-tkms*cp*rho*(tabs-soilt) & + *(p1000mb*0.00001/patm)**rovcp + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'potential temp hfx',hfx + endif + hft=-tkms*cp*rho*(tabs-soilt) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'abs temp hfx',hft + endif + q1 = - fq*ras* (qvatm - qsg) + cmc2ms=0. + if (q1.lt.0.) then ! --- condensation - EDIR1=0. - EC1=0. - ETT1=0. + edir1=0. + ec1=0. + ett1=0. ! --- condensation if(myj) then -!-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 - CST= CST-EETA*DELT*vegfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'MYJ EETA cond', EETA - ENDIF +!-- moisture flux for coupling with myj pbl + eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3 + cst= cst-eeta*delt*vegfrac + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'myj eeta cond', eeta + endif else ! myj -!-- actual moisture flux from RUC LSM - DEW=QKMS*(QVATM-QSG) - EETA= - RHO*DEW - CST=CST+DELT*DEW*RAS * vegfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'RUC LSM EETA cond',EETA - ENDIF +!-- actual moisture flux from ruc lsm + dew=qkms*(qvatm-qsg) + eeta= - rho*dew + cst=cst+delt*dew*ras * vegfrac + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'ruc lsm eeta cond',eeta + endif endif ! myj - QFX= XLVm*EETA - EETA= - RHO*DEW - ELSE + qfx= xlvm*eeta + eeta= - rho*dew + else ! --- evaporation - EDIR1 = Q1*UMVEG *BETA - CMC2MS=CST/DELT*RAS - EC1 = Q1 * WETCAN * vegfrac + edir1 = q1*umveg *beta + cmc2ms=cst/delt*ras + ec1 = q1 * wetcan * vegfrac - CST=max(0.,CST-EC1 * DELT) + cst=max(0.,cst-ec1 * delt) -! if(EC1 > CMC2MS) then -! EC1 = min(cmc2ms,ec1) -! CST = 0. -! endif - - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print*,'Q1,umveg,beta',Q1,umveg,beta + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print*,'q1,umveg,beta',q1,umveg,beta print *,'wetcan,vegfrac',wetcan,vegfrac - print *,'EC1,CMC2MS',EC1,CMC2MS - ENDIF + print *,'ec1,cmc2ms',ec1,cmc2ms + endif if(myj) then -!-- moisture flux for coupling with MYJ PBL - EETA=-(QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3)*BETA - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'MYJ EETA', EETA*XLVm,EETA - ENDIF +!-- moisture flux for coupling with myj pbl + eeta=-(qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*1.e3)*beta + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'myj eeta', eeta*xlvm,eeta + endif else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ -!-- actual moisture flux from RUC LSM - EETA = (EDIR1 + EC1 + ETT1)*1.E3 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'RUC LSM EETA',EETA*XLVm,EETA - ENDIF +!-- actual moisture flux from ruc lsm + eeta = (edir1 + ec1 + ett1)*1.e3 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'ruc lsm eeta',eeta*xlvm,eeta + endif endif ! myj - QFX= XLVm * EETA - EETA = (EDIR1 + EC1 + ETT1)*1.E3 - ENDIF - S=SNFLX -! sublim=eeta - sublim=EDIR1*1.E3 -! Energy budget - FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNOWSOIL - FLTOT,RNET,HFT,QFX,S,SNOH,X=',FLTOT,RNET,HFT,XLVm*EETA,s,SNOH,X + qfx= xlvm * eeta + eeta = (edir1 + ec1 + ett1)*1.e3 + endif + s=snflx + sublim=edir1*1.e3 +! energy budget + fltot=rnet-hft-xlvm*eeta-s-snoh-x + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snowsoil - fltot,rnet,hft,qfx,s,snoh,x=',fltot,rnet,hft,xlvm*eeta,s,snoh,x print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta',& edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta - ENDIF + endif - 222 CONTINUE + 222 continue - 1123 FORMAT(I5,8F12.3) - 1133 FORMAT(I7,8E12.4) + 1123 format(i5,8f12.3) + 1133 format(i7,8e12.4) 123 format(i6,f6.2,7f8.1) - 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) + 122 format(1x,2i3,6f8.1,f8.3,f8.2) !------------------------------------------------------------------- - END SUBROUTINE SNOWSOIL + end subroutine snowsoil !------------------------------------------------------------------- - SUBROUTINE SNOWSEAICE( & + subroutine snowseaice( & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & - meltfactor,rhonewsn,SNHEI_CRIT, & ! new - ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & - RHOSN,PATM,QVATM,QCATM, & - GLW,GSW,EMISS,RNET, & - QKMS,TKMS,RHO,myj, & + meltfactor,rhonewsn,snhei_crit, & ! new + iland,prcpms,rainf,newsnow,snhei,snwe,snowfrac, & + rhosn,patm,qvatm,qcatm, & + glw,gsw,emiss,rnet, & + qkms,tkms,rho,myj, & !--- sea ice parameters - ALB,ZNT, & + alb,znt, & tice,rhosice,capice,thdifice, & - zsmain,zshalf,DTDZS,DTDZS2,tbq, & + zsmain,zshalf,dtdzs,dtdzs2,tbq, & !--- constants - xlv,CP,rovcp,cw,stbolt,tabs, & + xlv,cp,rovcp,cw,stbolt,tabs, & !--- output variables ilnb,snweprint,snheiprint,rsm,tso, & dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & - SMELT,SNOH,SNFLX,SNOM,eeta, & + smelt,snoh,snflx,snom,eeta, & qfx,hfx,s,sublim,prcpl,fltot & ) !*************************************************************** -! Solving energy budget for snow on sea ice and heat diffusion +! solving energy budget for snow on sea ice and heat diffusion ! eqns. in snow and sea ice !*************************************************************** - IMPLICIT NONE + implicit none !------------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: ktau,nzs , & + integer, intent(in ) :: ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil + integer, intent(in ) :: i,j,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & - RAINF,NEWSNOW,RHONEWSN, & + real, intent(in ) :: delt,conflx,prcpms , & + rainf,newsnow,rhonewsn, & meltfactor, snhei_crit real :: rhonewcsn - LOGICAL, INTENT(IN ) :: myj -!--- 3-D Atmospheric variables - REAL, & - INTENT(IN ) :: PATM, & - QVATM, & - QCATM -!--- 2-D variables - REAL , & - INTENT(IN ) :: GLW, & - GSW, & - RHO, & - QKMS, & - TKMS + logical, intent(in ) :: myj +!--- 3-d atmospheric variables + real, & + intent(in ) :: patm, & + qvatm, & + qcatm +!--- 2-d variables + real , & + intent(in ) :: glw, & + gsw, & + rho, & + qkms, & + tkms !--- sea ice properties - REAL, DIMENSION(1:NZS) , & - INTENT(IN ) :: & + real, dimension(1:nzs) , & + intent(in ) :: & tice, & rhosice, & capice, & thdifice - REAL, INTENT(IN ) :: & - CW, & - XLV + real, intent(in ) :: & + cw, & + xlv - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real, dimension(1:nzs), intent(in) :: zsmain, & + zshalf, & + dtdzs2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real, dimension(1:nddzs), intent(in) :: dtdzs - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real, dimension(1:5001), intent(in) :: tbq !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TSO + real, dimension( 1:nzs ) , & + intent(inout) :: tso - INTEGER, INTENT(INOUT) :: ILAND + integer, intent(inout) :: iland !-------- 2-d variables - REAL , & - INTENT(INOUT) :: DEW, & - EETA, & - RHOSN, & - SUBLIM, & - PRCPL, & - ALB, & - EMISS, & - ZNT, & - QVG, & - QSG, & - QCG, & - QFX, & - HFX, & - S, & - SNWE, & - SNHEI, & - SMELT, & - SNOM, & - SNOH, & - SNFLX, & - SOILT, & - SOILT1, & - SNOWFRAC, & - TSNAV - - INTEGER, INTENT(INOUT) :: ILNB - - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT -!--- Local variables - - - INTEGER :: nzs1,nzs2,k,k1,kn,kk - REAL :: x,x1,x2,dzstop,ft,tn,denom - - REAL :: SNTH, NEWSN , & - TABS, T3, UPFLUX, XINET , & - BETA, SNWEPR,EPDT,PP - REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real , & + intent(inout) :: dew, & + eeta, & + rhosn, & + sublim, & + prcpl, & + alb, & + emiss, & + znt, & + qvg, & + qsg, & + qcg, & + qfx, & + hfx, & + s, & + snwe, & + snhei, & + smelt, & + snom, & + snoh, & + snflx, & + soilt, & + soilt1, & + snowfrac, & + tsnav + + integer, intent(inout) :: ilnb + + real, intent(out) :: rsm, & + snweprint, & + snheiprint +!--- local variables + + + integer :: nzs1,nzs2,k,k1,kn,kk + real :: x,x1,x2,dzstop,ft,tn,denom + + real :: snth, newsn , & + tabs, t3, upflux, xinet , & + beta, snwepr,epdt,pp + real :: cp,rovcp,g0,lv,xlvm,stbolt,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & - RIW,DELTSN,H + riw,deltsn,h - REAL :: rhocsn,thdifsn, & + real :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - REAL :: fso,fsn, & - FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & - FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & - TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & - SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real :: fso,fsn, & + fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11, & + fkq,r210,aa,bb,qs1,ts1,tq2,tx2, & + tdenom,aa1,rhcs,h1,tsob, snprim, & + snodif,soh,tnold,qgold,snohgnew + real, dimension(1:nzs) :: cotso,rhtso - REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr + real :: rnet,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt !----------------------------------------------------------------- - XLMELT=3.35E+5 + xlmelt=3.35e+5 !-- heat of sublimation of water vapor - XLVm=XLV+XLMELT -! STBOLT=5.670151E-8 - -!--- SNOW flag -- ISICE -! ILAND=isice - -!--- DELTSN - is the threshold for splitting the snow layer into 2 layers. -!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, -!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is -!--- computed using SNWE=0.03 m and current snow density. -!--- SNTH - the threshold below which the snow layer is combined with -!--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and -!--- equals 4 cm for snow density 400 kg/m^3. + xlvm=xlv+xlmelt -! increase thickness of top snow layer from 3 cm SWE to 5 cm SWE -! DELTSN=5.*SNHEI_CRIT -! snth=0.4*SNHEI_CRIT +!--- snow flag -- isice +! iland=isice - DELTSN=0.05*1.e3/rhosn +!--- deltsn - is the threshold for splitting the snow layer into 2 layers. +!--- with snow density 400 kg/m^3, this threshold is equal to 7.5 cm, +!--- equivalent to 0.03 m snwe. for other snow densities the threshold is +!--- computed using snwe=0.03 m and current snow density. +!--- snth - the threshold below which the snow layer is combined with +!--- the top sea ice layer. snth is computed using snwe=0.016 m, and +!--- equals 4 cm for snow density 400 kg/m^3. + + deltsn=0.05*1.e3/rhosn snth=0.01*1.e3/rhosn -! snth=0.01601*1.e3/rhosn -! For 2-layer snow model when the snow depth is marginlly higher than DELTSN, -! reset DELTSN to half of snow depth. - IF(SNHEI.GE.DELTSN+SNTH) THEN +! for 2-layer snow model when the snow depth is marginlly higher than deltsn, +! reset deltsn to half of snow depth. + if(snhei.ge.deltsn+snth) then if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'DELTSN ICE is changed,deltsn,snhei,snth', & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'deltsn ice is changed,deltsn,snhei,snth', & i,j, deltsn,snhei,snth - ENDIF - ENDIF + endif + endif - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 - RSM=0. + rhoice=900. + ci=rhoice*2100. + ras=rho*1.e-3 + riw=rhoice*1.e-3 + rsm=0. - XLMELT=3.35E+5 - RHOCSN=2090.* RHOSN + xlmelt=3.35e+5 + rhocsn=2090.* rhosn !18apr08 - add rhonewcsn - RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN - RAS=RHO*1.E-3 - - SOILTFRAC=SOILT - - SMELT=0. - SOH=0. - SNODIF=0. - SNOH=0. - SNOHGNEW=0. - RSM = 0. - RSMFRAC = 0. + rhonewcsn=2090.* rhonewsn + thdifsn = 0.265/rhocsn + ras=rho*1.e-3 + + soiltfrac=soilt + + smelt=0. + soh=0. + snodif=0. + snoh=0. + snohgnew=0. + rsm = 0. + rsmfrac = 0. fsn=1. fso=0. cvw=cw - NZS1=NZS-1 - NZS2=NZS-2 + nzs1=nzs-1 + nzs2=nzs-2 - QGOLD=QSG - TNOLD=SOILT - DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + qgold=qsg + tnold=soilt + dzstop=1./(zsmain(2)-zsmain(1)) snweprint=0. snheiprint=0. prcpl=prcpms -!*** DELTSN is the depth of the top layer of snow where +!*** deltsn is the depth of the top layer of snow where !*** there is a temperature gradient, the rest of the snow layer !*** is considered to have constant temperature - H=1. - SMELT=0. + h=1. + smelt=0. - FQ=QKMS - SNHEI=SNWE*1.e3/RHOSN - SNWEPR=SNWE + fq=qkms + snhei=snwe*1.e3/rhosn + snwepr=snwe -! check if all snow can evaporate during DT - BETA=1. - EPOT = -FQ*(QVATM-QSG) - EPDT = EPOT * RAS *DELT - IF(EPDT.GT.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) - SNWE=0. - ENDIF +! check if all snow can evaporate during dt + beta=1. + epot = -fq*(qvatm-qsg) + epdt = epot * ras *delt + if(epdt.gt.0. .and. snwepr.le.epdt) then + beta=snwepr/max(1.e-8,epdt) + snwe=0. + endif !****************************************************************************** -! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO +! coefficients for thomas algorithm for tso !****************************************************************************** cotso(1)=0. - rhtso(1)=TSO(NZS) - DO 33 K=1,NZS2 - KN=NZS-K - K1=2*KN-3 - X1=DTDZS(K1)*THDIFICE(KN-1) - X2=DTDZS(K1+1)*THDIFICE(KN) - FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & - -X2*(TSO(KN)-TSO(KN+1)) - DENOM=1.+X1+X2-X2*cotso(K) - cotso(K+1)=X1/DENOM - rhtso(K+1)=(FT+X2*rhtso(K))/DENOM - 33 CONTINUE -!--- THE NZS element in COTSO and RHTSO will be for snow -!--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH - IF(SNHEI.GE.SNTH) then - if(snhei.le.DELTSN+SNTH) then + rhtso(1)=tso(nzs) + do 33 k=1,nzs2 + kn=nzs-k + k1=2*kn-3 + x1=dtdzs(k1)*thdifice(kn-1) + x2=dtdzs(k1+1)*thdifice(kn) + ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) & + -x2*(tso(kn)-tso(kn+1)) + denom=1.+x1+x2-x2*cotso(k) + cotso(k+1)=x1/denom + rhtso(k+1)=(ft+x2*rhtso(k))/denom + 33 continue +!--- the nzs element in cotso and rhtso will be for snow +!--- there will be 2 layers in snow if it is deeper than deltsn+snth + if(snhei.ge.snth) then + if(snhei.le.deltsn+snth) then !-- 1-layer snow model ilnb=1 snprim=max(snth,snhei) soilt1=tso(1) tsob=tso(1) - XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) - DDZSN = XSN / SNPRIM - X1SN = DDZSN * thdifsn - X2 = DTDZS(1)*THDIFICE(1) - FT = TSO(1)+X1SN*(SOILT-TSO(1)) & - -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) - cotso(NZS)=X1SN/DENOM - rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM - cotsn=cotso(NZS) - rhtsn=rhtso(NZS) -!*** Average temperature of snow pack (C) + xsn = delt/2./(zshalf(2)+0.5*snprim) + ddzsn = xsn / snprim + x1sn = ddzsn * thdifsn + x2 = dtdzs(1)*thdifice(1) + ft = tso(1)+x1sn*(soilt-tso(1)) & + -x2*(tso(1)-tso(2)) + denom = 1. + x1sn + x2 -x2*cotso(nzs1) + cotso(nzs)=x1sn/denom + rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom + cotsn=cotso(nzs) + rhtsn=rhtso(nzs) +!*** average temperature of snow pack (c) tsnav=0.5*(soilt+tso(1)) & -273.15 else -!-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth +!-- 2 layers in snow, soilt1 is temperasture at deltsn depth ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*SNHEI) - XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) - DDZSN = XSN / DELTSN - DDZSN1 = XSN1 / (SNHEI-DELTSN) - X1SN = DDZSN * thdifsn - X1SN1 = DDZSN1 * thdifsn - X2 = DTDZS(1)*THDIFICE(1) - FT = TSO(1)+X1SN1*(SOILT1-TSO(1)) & - -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN1 + X2 - X2*cotso(NZS1) + xsn = delt/2./(0.5*snhei) + xsn1= delt/2./(zshalf(2)+0.5*(snhei-deltsn)) + ddzsn = xsn / deltsn + ddzsn1 = xsn1 / (snhei-deltsn) + x1sn = ddzsn * thdifsn + x1sn1 = ddzsn1 * thdifsn + x2 = dtdzs(1)*thdifice(1) + ft = tso(1)+x1sn1*(soilt1-tso(1)) & + -x2*(tso(1)-tso(2)) + denom = 1. + x1sn1 + x2 - x2*cotso(nzs1) cotso(nzs)=x1sn1/denom rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom ftsnow = soilt1+x1sn*(soilt-soilt1) & -x1sn1*(soilt1-tso(1)) - denomsn = 1. + X1SN + X1SN1 - X1SN1*cotso(NZS) + denomsn = 1. + x1sn + x1sn1 - x1sn1*cotso(nzs) cotsn=x1sn/denomsn - rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn -!*** Average temperature of snow pack (C) + rhtsn=(ftsnow+x1sn1*rhtso(nzs))/denomsn +!*** average temperature of snow pack (c) tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & + +(soilt1+tso(1))*(snhei-deltsn)) & -273.15 endif - ENDIF + endif - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + if(snhei.lt.snth.and.snhei.gt.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first sea ice layer. - snprim=SNHEI+zsmain(2) - fsn=SNHEI/snprim + snprim=snhei+zsmain(2) + fsn=snhei/snprim fso=1.-fsn soilt1=tso(1) tsob=tso(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) - DDZSN = XSN /snprim - X1SN = DDZSN * (fsn*thdifsn+fso*thdifice(1)) - X2=DTDZS(2)*THDIFICE(2) - FT=TSO(2)+X1SN*(SOILT-TSO(2))- & - X2*(TSO(2)-TSO(3)) + xsn = delt/2./((zshalf(3)-zsmain(2))+0.5*snprim) + ddzsn = xsn /snprim + x1sn = ddzsn * (fsn*thdifsn+fso*thdifice(1)) + x2=dtdzs(2)*thdifice(2) + ft=tso(2)+x1sn*(soilt-tso(2))- & + x2*(tso(2)-tso(3)) denom = 1. + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom - rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom + rhtso(nzs1)=(ft+x2*rhtso(nzs-2))/denom tsnav=0.5*(soilt+tso(1)) & -273.15 - cotso(nzs)=cotso(NZS1) + cotso(nzs)=cotso(nzs1) rhtso(nzs)=rhtso(nzs1) - cotsn=cotso(NZS) - rhtsn=rhtso(NZS) - ENDIF + cotsn=cotso(nzs) + rhtsn=rhtso(nzs) + endif !************************************************************************ -!--- THE HEAT BALANCE EQUATION -!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes +!--- the heat balance equation +!18apr08 nmelt is the flag for melting, and snoh is heat of snow phase changes nmelt=0 - SNOH=0. - - EPOT=-QKMS*(QVATM-QSG) - RHCS=CAPICE(1) - H=1. - FKT=TKMS - D1=cotso(NZS1) - D2=rhtso(NZS1) - TN=SOILT - D9=THDIFICE(1)*RHCS*dzstop - D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT - R21=R211*CP*RHO - R22=.5/(THDIFICE(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 - R7=R6/TN - D11=RNET+R6 - - IF(SNHEI.GE.SNTH) THEN - if(snhei.le.DELTSN+SNTH) then + snoh=0. + + epot=-qkms*(qvatm-qsg) + rhcs=capice(1) + h=1. + fkt=tkms + d1=cotso(nzs1) + d2=rhtso(nzs1) + tn=soilt + d9=thdifice(1)*rhcs*dzstop + d10=tkms*cp*rho + r211=.5*conflx/delt + r21=r211*cp*rho + r22=.5/(thdifice(1)*delt*dzstop**2) + r6=emiss *stbolt*.5*tn**4 + r7=r6/tn + d11=rnet+r6 + + if(snhei.ge.snth) then + if(snhei.le.deltsn+snth) then !--- 1-layer snow - D1SN = cotso(NZS) - D2SN = rhtso(NZS) + d1sn = cotso(nzs) + d2sn = rhtso(nzs) else !--- 2-layer snow - D1SN = cotsn - D2SN = rhtsn + d1sn = cotsn + d2sn = rhtsn endif - D9SN= THDIFSN*RHOCSN / SNPRIM - R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) - ENDIF + d9sn= thdifsn*rhocsn / snprim + r22sn = snprim*snprim*0.5/(thdifsn*delt) + endif - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + if(snhei.lt.snth.and.snhei.gt.0.) then !--- thin snow is combined with sea ice - D1SN = D1 - D2SN = D2 - D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIFICE(1)*RHCS)/ & + d1sn = d1 + d2sn = d2 + d9sn = (fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)/ & snprim - R22SN = snprim*snprim*0.5 & - /((fsn*THDIFSN+fso*THDIFICE(1))*delt) - ENDIF + r22sn = snprim*snprim*0.5 & + /((fsn*thdifsn+fso*thdifice(1))*delt) + endif - IF(SNHEI.eq.0.)then + if(snhei.eq.0.)then !--- all snow is sublimated - D9SN = D9 - R22SN = R22 - D1SN = D1 - D2SN = D2 - ENDIF + d9sn = d9 + r22sn = r22 + d1sn = d1 + d2sn = d2 + endif -!---- TDENOM for snow - TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & - +RAINF*CVW*PRCPMS & - +RHOnewCSN*NEWSNOW/DELT - - FKQ=QKMS*RHO - R210=R211*RHO - AA=XLVM*(BETA*FKQ+R210)/TDENOM - BB=(D10*TABS+R21*TN+XLVM*(QVATM* & - (BETA*FKQ) & - +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & - )/TDENOM - AA1=AA - PP=PATM*1.E3 - AA1=AA1/PP +!---- tdenom for snow + tdenom = d9sn*(1.-d1sn +r22sn)+d10+r21+r7 & + +rainf*cvw*prcpms & + +rhonewcsn*newsnow/delt + + fkq=qkms*rho + r210=r211*rho + aa=xlvm*(beta*fkq+r210)/tdenom + bb=(d10*tabs+r21*tn+xlvm*(qvatm* & + (beta*fkq) & + +r210*qvg)+d11+d9sn*(d2sn+r22sn*tn) & + +rainf*cvw*prcpms*max(273.15,tabs) & + + rhonewcsn*newsnow/delt*min(273.15,tabs) & + )/tdenom + aa1=aa + pp=patm*1.e3 + aa1=aa1/pp !18apr08 - the iteration start point 212 continue - BB=BB-SNOH/TDENOM - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'VILKA-SNOW on SEAICE' + bb=bb-snoh/tdenom + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'vilka-snow on seaice' print *,'tn,aa1,bb,pp,fkq,r210', & tn,aa1,bb,pp,fkq,r210 - print *,'TABS,QVATM,TN,QVG=',TABS,QVATM,TN,QVG - ENDIF + print *,'tabs,qvatm,tn,qvg=',tabs,qvatm,tn,qvg + endif - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil) !--- it is saturation over snow - QVG=QS1 - QSG=QS1 - QCG=0. + qvg=qs1 + qsg=qs1 + qcg=0. -!--- SOILT - skin temperature - SOILT=TS1 +!--- soilt - skin temperature + soilt=ts1 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' AFTER VILKA-SNOW on SEAICE' - print *,' TS1,QS1: ', ts1,qs1 - ENDIF -! Solution for temperature at 7.5 cm depth and snow-seaice interface - IF(SNHEI.GE.SNTH) THEN - if(snhei.gt.DELTSN+SNTH) then + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' after vilka-snow on seaice' + print *,' ts1,qs1: ', ts1,qs1 + endif +! solution for temperature at 7.5 cm depth and snow-seaice interface + if(snhei.ge.snth) then + if(snhei.gt.deltsn+snth) then !-- 2-layer snow model - SOILT1=min(273.15,rhtsn+cotsn*SOILT) - TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) + soilt1=min(273.15,rhtsn+cotsn*soilt) + tso(1)=min(271.4,(rhtso(nzs)+cotso(nzs)*soilt1)) tsob=soilt1 else !-- 1 layer in snow - TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT)) - SOILT1=TSO(1) + tso(1)=min(271.4,(rhtso(nzs)+cotso(nzs)*soilt)) + soilt1=tso(1) tsob=tso(1) endif - ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN + elseif (snhei > 0. .and. snhei < snth) then ! blended - TSO(2)=min(271.4,(rhtso(NZS1)+cotso(NZS1)*SOILT)) + tso(2)=min(271.4,(rhtso(nzs1)+cotso(nzs1)*soilt)) tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) - SOILT1=TSO(1) - tsob=TSO(2) - ELSE + soilt1=tso(1) + tsob=tso(2) + else ! snow is melted - TSO(1)=min(271.4,SOILT) - SOILT1=min(271.4,SOILT) + tso(1)=min(271.4,soilt) + soilt1=min(271.4,soilt) tsob=tso(1) - ENDIF -!---- Final solution for TSO in sea ice - IF (SNHEI > 0. .and. SNHEI < SNTH) THEN + endif +!---- final solution for tso in sea ice + if (snhei > 0. .and. snhei < snth) then ! blended or snow is melted - DO K=3,NZS - KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) - END DO - ELSE - DO K=2,NZS - KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) - END DO - ENDIF -!--- For thin snow layer combined with the top soil layer -!--- TSO(i,j,1) is computed by linear interpolation between SOILT -!--- and TSO(i,j,2) -! if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then + do k=3,nzs + kk=nzs-k+1 + tso(k)=min(271.4,rhtso(kk)+cotso(kk)*tso(k-1)) + end do + else + do k=2,nzs + kk=nzs-k+1 + tso(k)=min(271.4,rhtso(kk)+cotso(kk)*tso(k-1)) + end do + endif +!--- for thin snow layer combined with the top soil layer +!--- tso(i,j,1) is computed by linear interpolation between soilt +!--- and tso(i,j,2) +! if(snhei.lt.snth.and.snhei.gt.0.)then ! tso(1)=min(271.4,tso(2)+(soilt-tso(2))*fso) ! soilt1=tso(1) ! tsob = tso(2) @@ -4261,95 +4252,92 @@ SUBROUTINE SNOWSEAICE( & if(nmelt.eq.1) go to 220 -!--- IF SOILT > 273.15 F then melting of snow can happen -! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN +!--- if soilt > 273.15 f then melting of snow can happen ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + if(soilt.gt.273.15.and.snwepr-beta*epot*ras*delt.gt.0..and.snhei.gt.0.) then ! nmelt = 1 -! soiltfrac=273.15 - soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) - - QSG= QSN(soiltfrac,TBQ)/PP - T3 = STBOLT*TNold*TNold*TNold - UPFLUX = T3 * 0.5*(TNold+SOILTfrac) - XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET - EPOT = -QKMS*(QVATM-QSG) - Q1=EPOT*RAS - - IF (Q1.LE.0.) THEN + soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,soilt) + + qsg= qsn(soiltfrac,tbq)/pp + t3 = stbolt*tnold*tnold*tnold + upflux = t3 * 0.5*(tnold+soiltfrac) + xinet = emiss*(glw-upflux) + epot = -qkms*(qvatm-qsg) + q1=epot*ras + + if (q1.le.0.) then ! --- condensation - DEW=-EPOT + dew=-epot - QFX= XLVM*RHO*DEW - EETA=QFX/XLVM - ELSE + qfx= xlvm*rho*dew + eeta=qfx/xlvm + else ! --- evaporation - EETA = Q1 * BETA *1.E3 + eeta = q1 * beta *1.e3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ - QFX= - XLVM * EETA - ENDIF - - HFX=D10*(TABS-soiltfrac) - - IF(SNHEI.GE.SNTH)then - SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM - SNFLX=SOH - ELSE - SOH=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* & - (soiltfrac-TSOB)/snprim - SNFLX=SOH - ENDIF - X= (R21+D9SN*R22SN)*(soiltfrac-TNOLD) + & - XLVM*R210*(QSG-QGOLD) -!-- SNOH is energy flux of snow phase change - SNOH=RNET+QFX +HFX & - +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) & - -SOH-X+RAINF*CVW*PRCPMS* & - (max(273.15,TABS)-soiltfrac) - - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNOWSEAICE melt I,J,SNOH,RNET,QFX,HFX,SOH,X',i,j,SNOH,RNET,QFX,HFX,SOH,X - print *,'RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac)', & - RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) - print *,'RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac)', & - RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) - ENDIF - SNOH=AMAX1(0.,SNOH) -!-- SMELT is speed of melting in M/S - SMELT= SNOH /XLMELT*1.E-3 - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - SMELT=AMAX1(0.,SMELT) - - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'1-SMELT i,j',smelt,i,j - ENDIF -!18apr08 - Egglston limit -! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) - SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'2-SMELT i,j',smelt,i,j - ENDIF + qfx= - xlvm * eeta + endif + + hfx=d10*(tabs-soiltfrac) + + if(snhei.ge.snth)then + soh=thdifsn*rhocsn*(soiltfrac-tsob)/snprim + snflx=soh + else + soh=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* & + (soiltfrac-tsob)/snprim + snflx=soh + endif + x= (r21+d9sn*r22sn)*(soiltfrac-tnold) + & + xlvm*r210*(qsg-qgold) +!-- snoh is energy flux of snow phase change + snoh=rnet+qfx +hfx & + +rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac) & + -soh-x+rainf*cvw*prcpms* & + (max(273.15,tabs)-soiltfrac) + + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snowseaice melt i,j,snoh,rnet,qfx,hfx,soh,x',i,j,snoh,rnet,qfx,hfx,soh,x + print *,'rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac)', & + rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac) + print *,'rainf*cvw*prcpms*(max(273.15,tabs)-soiltfrac)', & + rainf*cvw*prcpms*(max(273.15,tabs)-soiltfrac) + endif + snoh=amax1(0.,snoh) +!-- smelt is speed of melting in m/s + smelt= snoh /xlmelt*1.e-3 + smelt=amin1(smelt,snwepr/delt-beta*epot*ras) + smelt=amax1(0.,smelt) + + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'1-smelt i,j',smelt,i,j + endif +!18apr08 - egglston limit +! smelt= amin1 (smelt, 5.6e-7*meltfactor*max(1.,(soilt-273.15))) + smelt= amin1 (smelt, 5.6e-8*meltfactor*max(1.,(soilt-273.15))) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'2-smelt i,j',smelt,i,j + endif ! rr - potential melting - rr=SNWEPR/delt-BETA*EPOT*RAS - SMELT=min(SMELT,rr) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'3- SMELT i,j,smelt,rr',i,j,smelt,rr - ENDIF - SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + rr=snwepr/delt-beta*epot*ras + smelt=min(smelt,rr) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'3- smelt i,j,smelt,rr',i,j,smelt,rr + endif + snohgnew=smelt*xlmelt*1.e3 + snodif=amax1(0.,(snoh-snohgnew)) - SNOH=SNOHGNEW + snoh=snohgnew - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print*,'soiltfrac,soilt,SNOHGNEW,SNODIF=', & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print*,'soiltfrac,soilt,snohgnew,snodif=', & i,j,soiltfrac,soilt,snohgnew,snodif - print *,'SNOH,SNODIF',SNOH,SNODIF - ENDIF + print *,'snoh,snodif',snoh,snodif + endif -!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack +!*** from koren et al. (1999) 13% of snow melt stays in the snow pack rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) if(snhei > 0.01) then rsm=rsmfrac*smelt*delt @@ -4358,31 +4346,28 @@ SUBROUTINE SNOWSEAICE( & rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=AMAX1(0.,SMELT-rsm/delt) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'4-SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + smelt=amax1(0.,smelt-rsm/delt) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'4-smelt i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac - ENDIF + endif !-- update liquid equivalent of snow depth !-- for evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & + snwe = amax1(0.,(snwepr- & + (smelt+beta*epot*ras)*delt & ) ) -!!!! soilt=soiltfrac -!--- If there is no snow melting then just evaporation -!--- or condensation changes SNWE - ELSE +!--- if there is no snow melting then just evaporation +!--- or condensation changes snwe + else if(snhei.ne.0.) then - EPOT=-QKMS*(QVATM-QSG) - SNWE = AMAX1(0.,(SNWEPR- & - BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) + epot=-qkms*(qvatm-qsg) + snwe = amax1(0.,(snwepr- & + beta*epot*ras*delt)) endif - ENDIF + endif ! no iteration for snow on sea ice, because it will produce ! skin temperature higher than it is possible with snow on sea ice @@ -4391,318 +4376,317 @@ SUBROUTINE SNOWSEAICE( & if(smelt > 0..and. rsm > 0.) then if(snwe.le.rsm) then - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SEAICE SNWEQVATM .and. QVATM > QVG) then + qsg=qs1 + qvg=q1 +! if( qs1>qvatm .and. qvatm > qvg) then ! very dry soil ! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1 -! QVG = QVATM +! qvg = qvatm ! endif - TSO(1)=TS1 - QCG=0. - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if (i==421.and.j==280) then + tso(1)=ts1 + qcg=0. + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'q1,qsg,qvg,qvatm,alfa,h',q1,qsg,qvg,qvatm,alfa,h endif - 200 CONTINUE - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'200 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) - ENDIF + 200 continue + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'200 qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1) + endif -!--- SOILT - skin temperature - SOILT=TS1 +!--- soilt - skin temperature + soilt=ts1 -!---- Final solution for soil temperature - TSO - DO K=2,NZS - KK=NZS-K+1 - TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) - END DO +!---- final solution for soil temperature - tso + do k=2,nzs + kk=nzs-k+1 + tso(k)=rhtso(kk)+cotso(kk)*tso(k-1) + end do - X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & - XLV*rho*r211*(QVG-QGOLD) + x= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn) + & + xlv*rho*r211*(qvg-qgold) ! - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', & + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print*,'soiltemp storage, i,j,x,soilt,tn,qvg,qvgold', & i,j,x,soilt,tn,qvg,qgold - print *,'TEMP term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN)',& - (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) - print *,'QV term XLV*rho*r211*(QVG-QGOLD)',XLV*rho*r211*(QVG-QGOLD) - ENDIF - X=X & + print *,'temp term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn)',& + (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(soilt-tn) + print *,'qv term xlv*rho*r211*(qvg-qgold)',xlv*rho*r211*(qvg-qgold) + endif + x=x & ! "heat" from rain - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -rainf*cvw*prcpms*(max(273.15,tabs)-soilt) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'x=',x - ENDIF + endif !-------------------------------------------------------------------- - END SUBROUTINE SOILTEMP + end subroutine soiltemp !-------------------------------------------------------------------- - SUBROUTINE SNOWTEMP( & + subroutine snowtemp( & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & snwe,snwepr,snhei,newsnow,snowfrac, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor - PRCPMS,RAINF, & - PATM,TABS,QVATM,QCATM, & - GLW,GSW,EMISS,RNET, & - QKMS,TKMS,PC,RHO,VEGFRAC, & - THDIF,CAP,DRYCAN,WETCAN,CST, & - TRANF,TRANSUM,DEW,MAVAIL, & + prcpms,rainf, & + patm,tabs,qvatm,qcatm, & + glw,gsw,emiss,rnet, & + qkms,tkms,pc,rho,vegfrac, & + thdif,cap,drycan,wetcan,cst, & + tranf,transum,dew,mavail, & !--- soil fixed fields - DQM,QMIN,PSIS,BCLH, & - ZSMAIN,ZSHALF,DTDZS,TBQ, & + dqm,qmin,psis,bclh, & + zsmain,zshalf,dtdzs,tbq, & !--- constants - XLVM,CP,rovcp,G0_P,CVW,STBOLT, & + xlvm,cp,rovcp,g0_p,cvw,stbolt, & !--- output variables - SNWEPRINT,SNHEIPRINT,RSM, & - TSO,SOILT,SOILT1,TSNAV,QVG,QSG,QCG, & - SMELT,SNOH,SNFLX,S,ILNB,X) + snweprint,snheiprint,rsm, & + tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & + smelt,snoh,snflx,s,ilnb,x) !******************************************************************** -! Energy budget equation and heat diffusion eqn are +! energy budget equation and heat diffusion eqn are ! solved here to obtain snow and soil temperatures ! -! DELT - time step (s) +! delt - time step (s) ! ktau - numver of time step -! CONFLX - depth of constant flux layer (m) -! IME, JME, KME, NZS - dimensions of the domain -! NROOT - number of levels within the root zone -! PRCPMS - precipitation rate in m/s -! COTSO, RHTSO - coefficients for implicit solution of +! conflx - depth of constant flux layer (m) +! ime, jme, kme, nzs - dimensions of the domain +! nroot - number of levels within the root zone +! prcpms - precipitation rate in m/s +! cotso, rhtso - coefficients for implicit solution of ! heat diffusion equation -! THDIF - thermal diffusivity (W/m/K) -! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! thdif - thermal diffusivity (w/m/k) +! qsg,qvg,qcg - saturated mixing ratio, mixing ratio of ! water vapor and cloud at the ground ! surface, respectively (kg/kg) -! PATM - pressure [bar] -! QCATM,QVATM - cloud and water vapor mixing ratio +! patm - pressure [bar] +! qcatm,qvatm - cloud and water vapor mixing ratio ! at the first atm. level (kg/kg) -! EMISS,RNET - emissivity (0-1) of the ground surface and net -! radiation at the surface (W/m^2) -! QKMS - exchange coefficient for water vapor in the +! emiss,rnet - emissivity (0-1) of the ground surface and net +! radiation at the surface (w/m^2) +! qkms - exchange coefficient for water vapor in the ! surface layer (m/s) -! TKMS - exchange coefficient for heat in the surface +! tkms - exchange coefficient for heat in the surface ! layer (m/s) -! PC - plant coefficient (resistance) -! RHO - density of atmosphere near surface (kg/m^3) -! VEGFRAC - greeness fraction (0-1) -! CAP - volumetric heat capacity (J/m^3/K) -! DRYCAN - dry fraction of vegetated area where +! pc - plant coefficient (resistance) +! rho - density of atmosphere near surface (kg/m^3) +! vegfrac - greeness fraction (0-1) +! cap - volumetric heat capacity (j/m^3/k) +! drycan - dry fraction of vegetated area where ! transpiration may take place (0-1) -! WETCAN - fraction of vegetated area covered by canopy +! wetcan - fraction of vegetated area covered by canopy ! water (0-1) -! TRANSUM - transpiration function integrated over the +! transum - transpiration function integrated over the ! rooting zone (m) -! DEW - dew in kg/m^2/s -! MAVAIL - fraction of maximum soil moisture in the top +! dew - dew in kg/m^2/s +! mavail - fraction of maximum soil moisture in the top ! layer (0-1) -! ZSMAIN - main levels in soil (m) -! ZSHALF - middle of the soil layers (m) -! DTDZS - dt/(2.*dzshalf*dzmain) -! TBQ - table to define saturated mixing ration +! zsmain - main levels in soil (m) +! zshalf - middle of the soil layers (m) +! dtdzs - dt/(2.*dzshalf*dzmain) +! tbq - table to define saturated mixing ration ! of water vapor for given temperature and pressure -! TSO - soil temperature (K) -! SOILT - skin temperature (K) +! tso - soil temperature (k) +! soilt - skin temperature (k) ! !********************************************************************* - IMPLICIT NONE + implicit none !--------------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + integer, intent(in ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & - RAINF,NEWSNOW,DELTSN,SNTH , & - TABS,TRANSUM,SNWEPR , & + integer, intent(in ) :: i,j,iland,isoil + real, intent(in ) :: delt,conflx,prcpms , & + rainf,newsnow,deltsn,snth , & + tabs,transum,snwepr , & rhonewsn,meltfactor real :: rhonewcsn -!--- 3-D Atmospheric variables - REAL, & - INTENT(IN ) :: PATM, & - QVATM, & - QCATM -!--- 2-D variables - REAL , & - INTENT(IN ) :: GLW, & - GSW, & - RHO, & - PC, & - VEGFRAC, & - QKMS, & - TKMS +!--- 3-d atmospheric variables + real, & + intent(in ) :: patm, & + qvatm, & + qcatm +!--- 2-d variables + real , & + intent(in ) :: glw, & + gsw, & + rho, & + pc, & + vegfrac, & + qkms, & + tkms !--- soil properties - REAL , & - INTENT(IN ) :: & - BCLH, & - DQM, & - PSIS, & - QMIN - - REAL, INTENT(IN ) :: CP, & - ROVCP, & - CVW, & - STBOLT, & - XLVM, & - G0_P + real , & + intent(in ) :: & + bclh, & + dqm, & + psis, & + qmin + + real, intent(in ) :: cp, & + rovcp, & + cvw, & + stbolt, & + xlvm, & + g0_p - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - THDIF, & - CAP, & - TRANF + real, dimension(1:nzs), intent(in) :: zsmain, & + zshalf, & + thdif, & + cap, & + tranf - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real, dimension(1:nddzs), intent(in) :: dtdzs - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real, dimension(1:5001), intent(in) :: tbq !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TSO + real, dimension( 1:nzs ) , & + intent(inout) :: tso !-------- 2-d variables - REAL , & - INTENT(INOUT) :: DEW, & - CST, & - RHOSN, & - EMISS, & - MAVAIL, & - QVG, & - QSG, & - QCG, & - SNWE, & - SNHEI, & - SNOWFRAC, & - SMELT, & - SNOH, & - SNFLX, & - S, & - SOILT, & - SOILT1, & - TSNAV - - REAL, INTENT(INOUT) :: DRYCAN, WETCAN - - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT - INTEGER, INTENT(OUT) :: ilnb -!--- Local variables - - - INTEGER :: nzs1,nzs2,k,k1,kn,kk - - REAL :: x,x1,x2,x4,dzstop,can,ft,sph, & + real , & + intent(inout) :: dew, & + cst, & + rhosn, & + emiss, & + mavail, & + qvg, & + qsg, & + qcg, & + snwe, & + snhei, & + snowfrac, & + smelt, & + snoh, & + snflx, & + s, & + soilt, & + soilt1, & + tsnav + + real, intent(inout) :: drycan, wetcan + + real, intent(out) :: rsm, & + snweprint, & + snheiprint + integer, intent(out) :: ilnb +!--- local variables + + + integer :: nzs1,nzs2,k,k1,kn,kk + + real :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom - REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - REAL :: t3,upflux,xinet,ras, & + real :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - REAL :: fso,fsn, & - FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & - PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & - TDENOM,C,CC,AA1,RHCS,H1, & + real :: fso,fsn, & + fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11, & + pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2, & + tdenom,c,cc,aa1,rhcs,h1, & tsob, snprim, sh1, sh2, & smeltg,snohg,snodif,soh, & - CMC2MS,TNOLD,QGOLD,SNOHGNEW + cmc2ms,tnold,qgold,snohgnew - REAL, DIMENSION(1:NZS) :: transp,cotso,rhtso - REAL :: edir1, & + real, dimension(1:nzs) :: transp,cotso,rhtso + real :: edir1, & ec1, & ett1, & eeta, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr + real :: rnet,rsmfrac,soiltfrac,hsn,rr,keff,fact integer :: nmelt, iter !----------------------------------------------------------------- @@ -5055,1065 +5034,1129 @@ SUBROUTINE SNOWTEMP( & cotso (k)=0. rhtso (k)=0. enddo + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + keff = 0.265 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt - ENDIF - XLMELT=3.35E+5 - RHOCSN=2090.* RHOSN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then +print *, 'snowtemp: snhei,snth,soilt1: ',snhei,snth,soilt1,soilt + endif + xlmelt=3.35e+5 + rhocsn=2090.* rhosn !18apr08 - add rhonewcsn - RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN - RAS=RHO*1.E-3 - - SOILTFRAC=SOILT - - SMELT=0. - SOH=0. - SMELTG=0. - SNOHG=0. - SNODIF=0. - RSM = 0. - RSMFRAC = 0. + rhonewcsn=2090.* rhonewsn + + if(isncond_opt == 1) then + !-- old version thdifsn = 0.265/rhocsn + thdifsn = 0.265/rhocsn + else + !-- 07jun19 - thermal conductivity (k_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * rhosn*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + endif + if(newsnow <= 0. .and. snhei > 1. .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the rockie's with snow depth > 1 m). + !-- based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. thdifsn = 0.452/(2090*488)=4.431718e-7 + !-- in future a better compaction scheme is needed for these areas. + thdifsn = 4.431718e-7 + else + thdifsn = keff/rhocsn * fact + endif + endif ! isncond_opt + + ras=rho*1.e-3 + + soiltfrac=soilt + + smelt=0. + soh=0. + smeltg=0. + snohg=0. + snodif=0. + rsm = 0. + rsmfrac = 0. fsn=1. fso=0. -! hsn=snhei - NZS1=NZS-1 - NZS2=NZS-2 + nzs1=nzs-1 + nzs2=nzs-2 - QGOLD=QVG - DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + qgold=qvg + dzstop=1./(zsmain(2)-zsmain(1)) !****************************************************************************** -! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO +! coefficients for thomas algorithm for tso !****************************************************************************** -! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) -! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did +! did=2.*(zsmain(nzs)-zshalf(nzs)) +! h1=dtdzs(8)*thdif(nzs-1)*(zshalf(nzs)-zshalf(nzs-1))/did ! cotso(1)=h1/(1.+h1) ! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ ! 1 (1.+h1) cotso(1)=0. - rhtso(1)=TSO(NZS) - DO 33 K=1,NZS2 - KN=NZS-K - K1=2*KN-3 - X1=DTDZS(K1)*THDIF(KN-1) - X2=DTDZS(K1+1)*THDIF(KN) - FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & - -X2*(TSO(KN)-TSO(KN+1)) - DENOM=1.+X1+X2-X2*cotso(K) - cotso(K+1)=X1/DENOM - rhtso(K+1)=(FT+X2*rhtso(K))/DENOM - 33 CONTINUE -!--- THE NZS element in COTSO and RHTSO will be for snow -!--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH - IF(SNHEI.GE.SNTH) then - if(snhei.le.DELTSN+SNTH) then + rhtso(1)=tso(nzs) + do 33 k=1,nzs2 + kn=nzs-k + k1=2*kn-3 + x1=dtdzs(k1)*thdif(kn-1) + x2=dtdzs(k1+1)*thdif(kn) + ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) & + -x2*(tso(kn)-tso(kn+1)) + denom=1.+x1+x2-x2*cotso(k) + cotso(k+1)=x1/denom + rhtso(k+1)=(ft+x2*rhtso(k))/denom + 33 continue +!--- the nzs element in cotso and rhtso will be for snow +!--- there will be 2 layers in snow if it is deeper than deltsn+snth + if(snhei.ge.snth) then + if(snhei.le.deltsn+snth) then !-- 1-layer snow model - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'1-layer - snth,snhei,deltsn',snth,snhei,deltsn - ENDIF + endif ilnb=1 snprim=max(snth,snhei) tsob=tso(1) soilt1=tso(1) - XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) - DDZSN = XSN / SNPRIM - X1SN = DDZSN * thdifsn - X2 = DTDZS(1)*THDIF(1) - FT = TSO(1)+X1SN*(SOILT-TSO(1)) & - -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) - cotso(NZS)=X1SN/DENOM - rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM - cotsn=cotso(NZS) - rhtsn=rhtso(NZS) -!*** Average temperature of snow pack (C) + xsn = delt/2./(zshalf(2)+0.5*snprim) + ddzsn = xsn / snprim + x1sn = ddzsn * thdifsn + x2 = dtdzs(1)*thdif(1) + ft = tso(1)+x1sn*(soilt-tso(1)) & + -x2*(tso(1)-tso(2)) + denom = 1. + x1sn + x2 -x2*cotso(nzs1) + cotso(nzs)=x1sn/denom + rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom + cotsn=cotso(nzs) + rhtsn=rhtso(nzs) +!*** average temperature of snow pack (c) tsnav=0.5*(soilt+tso(1)) & -273.15 else -!-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +!-- 2 layers in snow, soilt1 is temperasture at deltsn depth + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'2-layer - snth,snhei,deltsn',snth,snhei,deltsn - ENDIF + endif ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*deltsn) - XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) - DDZSN = XSN / DELTSN - DDZSN1 = XSN1 / (SNHEI-DELTSN) - X1SN = DDZSN * thdifsn - X1SN1 = DDZSN1 * thdifsn - X2 = DTDZS(1)*THDIF(1) - FT = TSO(1)+X1SN1*(SOILT1-TSO(1)) & - -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN1 + X2 - X2*cotso(NZS1) + xsn = delt/2./(0.5*deltsn) + xsn1= delt/2./(zshalf(2)+0.5*(snhei-deltsn)) + ddzsn = xsn / deltsn + ddzsn1 = xsn1 / (snhei-deltsn) + x1sn = ddzsn * thdifsn + x1sn1 = ddzsn1 * thdifsn + x2 = dtdzs(1)*thdif(1) + ft = tso(1)+x1sn1*(soilt1-tso(1)) & + -x2*(tso(1)-tso(2)) + denom = 1. + x1sn1 + x2 - x2*cotso(nzs1) cotso(nzs)=x1sn1/denom rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom ftsnow = soilt1+x1sn*(soilt-soilt1) & -x1sn1*(soilt1-tso(1)) - denomsn = 1. + X1SN + X1SN1 - X1SN1*cotso(NZS) + denomsn = 1. + x1sn + x1sn1 - x1sn1*cotso(nzs) cotsn=x1sn/denomsn - rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn -!*** Average temperature of snow pack (C) + rhtsn=(ftsnow+x1sn1*rhtso(nzs))/denomsn +!*** average temperature of snow pack (c) tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & + +(soilt1+tso(1))*(snhei-deltsn)) & -273.15 endif - ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then -! IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then + endif + if(snhei.lt.snth.and.snhei.gt.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. - snprim=SNHEI+zsmain(2) - fsn=SNHEI/snprim + snprim=snhei+zsmain(2) + fsn=snhei/snprim fso=1.-fsn soilt1=tso(1) tsob=tso(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) - DDZSN = XSN /snprim - X1SN = DDZSN * (fsn*thdifsn+fso*thdif(1)) - X2=DTDZS(2)*THDIF(2) - FT=TSO(2)+X1SN*(SOILT-TSO(2))- & - X2*(TSO(2)-TSO(3)) + xsn = delt/2./((zshalf(3)-zsmain(2))+0.5*snprim) + ddzsn = xsn /snprim + x1sn = ddzsn * (fsn*thdifsn+fso*thdif(1)) + x2=dtdzs(2)*thdif(2) + ft=tso(2)+x1sn*(soilt-tso(2))- & + x2*(tso(2)-tso(3)) denom = 1. + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom - rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom + rhtso(nzs1)=(ft+x2*rhtso(nzs-2))/denom tsnav=0.5*(soilt+tso(1)) & -273.15 - cotso(NZS)=cotso(nzs1) - rhtso(NZS)=rhtso(nzs1) - cotsn=cotso(NZS) - rhtsn=rhtso(NZS) + cotso(nzs)=cotso(nzs1) + rhtso(nzs)=rhtso(nzs1) + cotsn=cotso(nzs) + rhtsn=rhtso(nzs) - ENDIF + endif !************************************************************************ -!--- THE HEAT BALANCE EQUATION (Smirnova et al. 1996, EQ. 21,26) -!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes +!--- the heat balance equation (Smirnova et al. 1996, eq. 21,26) +!18apr08 nmelt is the flag for melting, and snoh is heat of snow phase changes nmelt=0 - SNOH=0. - - ETT1=0. - EPOT=-QKMS*(QVATM-QGOLD) - RHCS=CAP(1) - H=1. - TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) - CAN=WETCAN+TRANS - UMVEG=1.-VEGFRAC - FKT=TKMS - D1=cotso(NZS1) - D2=rhtso(NZS1) - TN=SOILT - D9=THDIF(1)*RHCS*dzstop - D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT - R21=R211*CP*RHO - R22=.5/(THDIF(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 - R7=R6/TN - D11=RNET+R6 - - IF(SNHEI.GE.SNTH) THEN - if(snhei.le.DELTSN+SNTH) then + snoh=0. + + ett1=0. + epot=-qkms*(qvatm-qgold) + rhcs=cap(1) + h=1. + trans=transum*drycan/zshalf(nroot+1) + can=wetcan+trans + umveg=1.-vegfrac + fkt=tkms + d1=cotso(nzs1) + d2=rhtso(nzs1) + tn=soilt + d9=thdif(1)*rhcs*dzstop + d10=tkms*cp*rho + r211=.5*conflx/delt + r21=r211*cp*rho + r22=.5/(thdif(1)*delt*dzstop**2) + r6=emiss *stbolt*.5*tn**4 + r7=r6/tn + d11=rnet+r6 + + if(snhei.ge.snth) then + if(snhei.le.deltsn+snth) then !--- 1-layer snow - D1SN = cotso(NZS) - D2SN = rhtso(NZS) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + d1sn = cotso(nzs) + d2sn = rhtso(nzs) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'1 layer d1sn,d2sn',i,j,d1sn,d2sn - ENDIF + endif else !--- 2-layer snow - D1SN = cotsn - D2SN = rhtsn - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + d1sn = cotsn + d2sn = rhtsn + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'2 layers d1sn,d2sn',i,j,d1sn,d2sn - ENDIF + endif endif - D9SN= THDIFSN*RHOCSN / SNPRIM - R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'1 or 2 layers D9sn,R22sn',d9sn,r22sn - ENDIF - ENDIF + d9sn= thdifsn*rhocsn / snprim + r22sn = snprim*snprim*0.5/(thdifsn*delt) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'1 or 2 layers d9sn,r22sn',d9sn,r22sn + endif + endif - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + if(snhei.lt.snth.and.snhei.gt.0.) then !--- thin snow is combined with soil - D1SN = D1 - D2SN = D2 - D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIF(1)*RHCS)/ & + d1sn = d1 + d2sn = d2 + d9sn = (fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)/ & snprim - R22SN = snprim*snprim*0.5 & - /((fsn*THDIFSN+fso*THDIF(1))*delt) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' Combined D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN - ENDIF - ENDIF - IF(SNHEI.eq.0.)then + r22sn = snprim*snprim*0.5 & + /((fsn*thdifsn+fso*thdif(1))*delt) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' combined d9sn,r22sn,d1sn,d2sn: ',d9sn,r22sn,d1sn,d2sn + endif + endif + if(snhei.eq.0.)then !--- all snow is sublimated - D9SN = D9 - R22SN = R22 - D1SN = D1 - D2SN = D2 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' SNHEI = 0, D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN - ENDIF - ENDIF + d9sn = d9 + r22sn = r22 + d1sn = d1 + d2sn = d2 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,' snhei = 0, d9sn,r22sn,d1sn,d2sn: ',d9sn,r22sn,d1sn,d2sn + endif + endif 2211 continue !18apr08 - the snow melt iteration start point 212 continue -!---- TDENOM for snow - TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & - +RAINF*CVW*PRCPMS & - +RHOnewCSN*NEWSNOW/DELT - - FKQ=QKMS*RHO - R210=R211*RHO - C=VEGFRAC*FKQ*CAN - CC=C*XLVM/TDENOM - AA=XLVM*(BETA*FKQ*UMVEG+R210)/TDENOM - BB=(D10*TABS+R21*TN+XLVM*(QVATM* & - (BETA*FKQ*UMVEG+C) & - +R210*QGOLD)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & - )/TDENOM - AA1=AA+CC - PP=PATM*1.E3 - AA1=AA1/PP - BB=BB-SNOH/TDENOM - - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) - TQ2=QVATM - TX2=TQ2*(1.-H) - Q1=TX2+H*QS1 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 - ENDIF - IF(Q1.LT.QS1) GOTO 100 +!---- tdenom for snow + tdenom = d9sn*(1.-d1sn +r22sn)+d10+r21+r7 & + +rainf*cvw*prcpms & + +rhonewcsn*newsnow/delt + + fkq=qkms*rho + r210=r211*rho + c=vegfrac*fkq*can + cc=c*xlvm/tdenom + aa=xlvm*(beta*fkq*umveg+r210)/tdenom + bb=(d10*tabs+r21*tn+xlvm*(qvatm* & + (beta*fkq*umveg+c) & + +r210*qgold)+d11+d9sn*(d2sn+r22sn*tn) & + +rainf*cvw*prcpms*max(273.15,tabs) & + + rhonewcsn*newsnow/delt*min(273.15,tabs) & + )/tdenom + aa1=aa+cc + pp=patm*1.e3 + aa1=aa1/pp + bb=bb-snoh/tdenom + + call vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil) + tq2=qvatm + tx2=tq2*(1.-h) + q1=tx2+h*qs1 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'vilka1 - ts1,qs1,tq2,h,tx2,q1',ts1,qs1,tq2,h,tx2,q1 + endif + if(q1.lt.qs1) goto 100 !--- if no saturation - goto 100 !--- if saturation - goto 90 - 90 QVG=QS1 - QSG=QS1 - QCG=max(0.,Q1-QS1) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) - ENDIF - GOTO 200 - 100 BB=BB-AA*TX2 - AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) - Q1=TX2+H*QS1 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 - ENDIF - IF(Q1.GT.QS1) GOTO 90 - QSG=QS1 - QVG=Q1 - QCG=0. - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'No Saturation QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) - ENDIF - 200 CONTINUE + 90 qvg=qs1 + qsg=qs1 + qcg=max(0.,q1-qs1) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'90 qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1) + endif + goto 200 + 100 bb=bb-aa*tx2 + aa=(aa*h+cc)/pp + call vilka(tn,aa,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil) + q1=tx2+h*qs1 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'vilka2 - ts1,qs1,h,tx2,q1',ts1,qs1,tq2,h,tx2,q1 + endif + if(q1.gt.qs1) goto 90 + qsg=qs1 + qvg=q1 + qcg=0. + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'no saturation qvg,qsg,qcg,tso(1)',qvg,qsg,qcg,tso(1) + endif + 200 continue -!--- SOILT - skin temperature - SOILT=TS1 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - IF(i.eq.266.and.j.eq.447) then +!--- soilt - skin temperature + soilt=ts1 + + if(nmelt==1 .and. snowfrac==1. .and. snwe > 0. .and. soilt > 273.15) then + !--7feb22 on the second iteration when snoh is known and snwe > 0. after melting, + !-- check if the snow skin temperature is = 0. .and. SNHEI < SNTH) THEN + elseif (snhei > 0. .and. snhei < snth) then ! blended - TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT + tso(2)=rhtso(nzs1)+cotso(nzs1)*soilt tso(1)=(tso(2)+(soilt-tso(2))*fso) - SOILT1=TSO(1) - tsob=TSO(2) - ELSE -!-- very thin or zero snow. If snow is thin we suppose that -!--- tso(i,j,1)=SOILT, and later we recompute tso(i,j,1) - TSO(1)=SOILT - SOILT1=SOILT - tsob=TSO(1) -!new tsob=tso(2) - ENDIF - -!---- Final solution for TSO - IF (SNHEI > 0. .and. SNHEI < SNTH) THEN + soilt1=tso(1) + tsob=tso(2) + else +!-- very thin or zero snow. if snow is thin we suppose that +!--- tso(i,j,1)=soilt, and later we recompute tso(i,j,1) + tso(1)=soilt + soilt1=soilt + tsob=tso(1) + endif + if(nmelt==1.and.snowfrac==1.) then + !-- second iteration with full snow cover + soilt1= min(273.15,soilt1) + tso(1)= min(273.15,tso(1)) + tsob = min(273.15,tsob) + endif + + +!---- final solution for tso + if (snhei > 0. .and. snhei < snth) then ! blended or snow is melted - DO K=3,NZS - KK=NZS-K+1 - TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) - END DO - - ELSE - DO K=2,NZS - KK=NZS-K+1 - TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) - END DO - ENDIF -!--- For thin snow layer combined with the top soil layer -!--- TSO(1) is recomputed by linear interpolation between SOILT -!--- and TSO(i,j,2) -! if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then + do k=3,nzs + kk=nzs-k+1 + tso(k)=rhtso(kk)+cotso(kk)*tso(k-1) + end do + + else + do k=2,nzs + kk=nzs-k+1 + tso(k)=rhtso(kk)+cotso(kk)*tso(k-1) + end do + endif +!--- for thin snow layer combined with the top soil layer +!--- tso(1) is recomputed by linear interpolation between soilt +!--- and tso(i,j,2) +! if(snhei.lt.snth.and.snhei.gt.0.)then ! tso(1)=tso(2)+(soilt-tso(2))*fso ! soilt1=tso(1) ! tsob = tso(2) ! endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'SOILT,SOILT1,tso,TSOB,QSG',i,j,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'soilt,soilt1,tso,tsob,qsg',i,j,soilt,soilt1,tso,tsob,qsg,'nmelt=',nmelt + endif if(nmelt.eq.1) go to 220 -!--- IF SOILT > 273.15 F then melting of snow can happen -! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN +!--- if soilt > 273.15 f then melting of snow can happen +! if(soilt.gt.273.15.and.snhei.gt.0.) then ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN + if(soilt.gt.273.15.and.beta==1..and.snhei.gt.0.) then nmelt = 1 - soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT - QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) - qvg=qsg - T3 = STBOLT*TN*TN*TN - UPFLUX = T3 * 0.5*(TN + SOILTfrac) - XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET - EPOT = -QKMS*(QVATM-QSG) - Q1=EPOT*RAS - - IF (Q1.LE.0..or.iter==1) THEN + soiltfrac=snowfrac*273.15+(1.-snowfrac)*soilt + qsg=min(qsg, qsn(soiltfrac,tbq)/pp) + qvg=snowfrac*qsg+(1.-snowfrac)*qvg + t3 = stbolt*tn*tn*tn + upflux = t3 * 0.5*(tn + soiltfrac) + xinet = emiss*(glw-upflux) + epot = -qkms*(qvatm-qsg) + q1=epot*ras + + if (q1.le.0..or.iter==1) then ! --- condensation - DEW=-EPOT - DO K=1,NZS - TRANSP(K)=0. - ENDDO + dew=-epot + do k=1,nzs + transp(k)=0. + enddo - QFX = -XLVM*RHO*DEW - EETA = QFX/XLVM - ELSE + qfx = -xlvm*rho*dew + eeta = qfx/xlvm + else ! --- evaporation - DO K=1,NROOT - TRANSP(K)=-VEGFRAC*q1 & - *TRANF(K)*DRYCAN/zshalf(NROOT+1) -! IF(TRANSP(K).GT.0.) TRANSP(K)=0. - ETT1=ETT1-TRANSP(K) - ENDDO - DO k=nroot+1,nzs + do k=1,nroot + transp(k)=-vegfrac*q1 & + *tranf(k)*drycan/zshalf(nroot+1) + ett1=ett1-transp(k) + enddo + do k=nroot+1,nzs transp(k)=0. enddo - EDIR1 = Q1*UMVEG * BETA - EC1 = Q1 * WETCAN * vegfrac - CMC2MS=CST/DELT*RAS -! EC1=MIN(CMC2MS,EC1) - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + edir1 = q1*umveg * beta + ec1 = q1 * wetcan * vegfrac + cmc2ms=cst/delt*ras + eeta = (edir1 + ec1 + ett1)*1.e3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ - QFX= XLVM * EETA - ENDIF + qfx= xlvm * eeta + endif - HFX=-D10*(TABS-soiltfrac) + hfx=-d10*(tabs-soiltfrac) - IF(SNHEI.GE.SNTH)then - SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM - SNFLX=SOH - ELSE - SOH=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & - (soiltfrac-TSOB)/snprim - SNFLX=SOH - ENDIF + if(snhei.ge.snth)then + soh=thdifsn*rhocsn*(soiltfrac-tsob)/snprim + snflx=soh + else + soh=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & + (soiltfrac-tsob)/snprim + snflx=soh + endif ! - X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & - XLVM*R210*(QVG-QGOLD) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNOWTEMP storage ',i,j,x - print *,'R21,D9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim', & - R21,D9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim - ENDIF + x= (r21+d9sn*r22sn)*(soiltfrac-tn) + & + xlvm*r210*(qvg-qgold) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snowtemp storage ',i,j,x + print *,'r21,d9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim', & + r21,d9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim + endif -!-- SNOH is energy flux of snow phase change - SNOH=RNET-QFX -HFX - SOH - X & - +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) & - +RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) - SNOH=AMAX1(0.,SNOH) -!-- SMELT is speed of melting in M/S - SMELT= SNOH /XLMELT*1.E-3 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'1- SMELT',i,j,smelt - ENDIF - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'2- SMELT',i,j,smelt - ENDIF - SMELT=AMAX1(0.,SMELT) +!-- snoh is energy flux of snow phase change + snoh=rnet-qfx -hfx - soh - x & + +rhonewcsn*newsnow/delt*(min(273.15,tabs)-soiltfrac) & + +rainf*cvw*prcpms*(max(273.15,tabs)-soiltfrac) + snoh=amax1(0.,snoh) +!-- smelt is speed of melting in m/s + smelt= snoh /xlmelt*1.e-3 + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'1- smelt',i,j,smelt + endif + if(epot.gt.0. .and. snwepr.le.epot*ras*delt) then +!-- all snow can evaporate + beta=snwepr/(epot*ras*delt) + smelt=amin1(smelt,snwepr/delt-beta*epot*ras) + snwe=0. + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'2- smelt',i,j,smelt + endif + goto 88 + endif -!18apr08 - Egglston limit -! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) - SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'3- SMELT',i,j,smelt - ENDIF + smelt=amax1(0.,smelt) + +!18apr08 - egglston limit + !-- 22apr22 do not limit snow melting for hail (rhonewsn > 450), or dense snow + !-- (rhosn > 350.) with very warm surface temperatures (>10c) + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then +! smelt= amin1 (smelt, 5.6e-7*meltfactor*max(1.,(soilt-273.15))) + smelt= amin1 (smelt, delt/60.*5.6e-8*meltfactor*max(1.,(soilt-273.15))) + + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'3- smelt',i,j,smelt + endif + endif ! rr - potential melting - rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) - SMELT=min(SMELT,rr) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr - ENDIF - SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + rr=max(0.,snwepr/delt-beta*epot*ras) + if(smelt > rr) then + smelt=min(smelt,rr) + snwe = 0. + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'4- smelt i,j,smelt,rr',i,j,smelt,rr + endif + endif - SNOH=SNOHGNEW - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNOH,SNODIF',SNOH,SNODIF - ENDIF + 88 continue + snohgnew=smelt*xlmelt*1.e3 + snodif=amax1(0.,(snoh-snohgnew)) + + snoh=snohgnew + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snoh,snodif',snoh,snodif + endif -!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack + if( smelt > 0.) then +!*** from koren et al. (1999) 13% of snow melt stays in the snow pack rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + if(snhei > 0.01 .and. rhosn < 350.) then rsm=rsmfrac*smelt*delt else ! do not keep melted water if snow depth is less that 1 cm rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=max(0.,SMELT-rsm/delt) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + if(rsm > 0.) then + smelt=max(0.,smelt-rsm/delt) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'5- smelt i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac - ENDIF + endif + endif ! rsm + + endif ! smelt > 0 !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & -! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & + if(snwe > 0.) then + snwe = amax1(0.,(snwepr- & + (smelt+beta*epot*ras)*delt & ) ) -!--- If there is no snow melting then just evaporation -!--- or condensation cxhanges SNWE - ELSE - if(snhei.ne.0.) then - EPOT=-QKMS*(QVATM-QSG) - SNWE = AMAX1(0.,(SNWEPR- & - BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) + endif + +!--- if there is no snow melting then just evaporation +!--- or condensation cxhanges snwe + else + if(snhei.ne.0..and. beta == 1.) then + epot=-qkms*(qvatm-qsg) + snwe = amax1(0.,(snwepr- & + beta*epot*ras*delt)) + else + !-- all snow is sublibated + snwe = 0. endif - ENDIF -!18apr08 - if snow melt occurred then go into iteration for energy budget -! solution + endif +!18apr08 - if snow melt occurred then go into iteration for energy budget solution if(nmelt.eq.1) goto 212 ! second interation 220 continue if(smelt.gt.0..and.rsm.gt.0.) then if(snwe.le.rsm) then - IF ( 1==1 ) THEN - print *,'SNWE 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + endif + if(newsnow <= 0. .and. snhei > 1. .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the rockie's with snow depth > 1 m). + !-- based on Sturm et al. keff=0.452 typical for hard snow slabs + !-- with rhosn=488 kg/m^3. thdifsn = 0.452/(2090*488)=4.431718e-7 + !-- in future a better compaction scheme is needed for these areas. + thdifsn = 4.431718e-7 + else + thdifsn = keff/rhocsn * fact + endif + endif ! isncond_opt - RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN endif endif -!--- Compute flux in the top snow layer - IF(SNHEI.GE.SNTH)then - S=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM - SNFLX=S - S=D9*(tso(1)-tso(2)) - ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.0.) then - S=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & - (soilt-TSOB)/snprim - SNFLX=S - S=D9*(tso(1)-tso(2)) - ELSE - S=D9SN*(SOILT-TSOB) - SNFLX=S - S=D9*(tso(1)-tso(2)) - ENDIF - - SNHEI=SNWE *1.E3 / RHOSN -!-- If ground surface temperature -!-- is above freezing snow can melt from the bottom. The following +!--- compute flux in the top snow layer + if(snhei.ge.snth)then + s=thdifsn*rhocsn*(soilt-tsob)/snprim + snflx=s + s=d9*(tso(1)-tso(2)) + elseif(snhei.lt.snth.and.snhei.gt.0.) then + s=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & + (soilt-tsob)/snprim + snflx=s + s=d9*(tso(1)-tso(2)) + else + s=d9sn*(soilt-tsob) + snflx=s + s=d9*(tso(1)-tso(2)) + endif + + snhei=snwe *1.e3 / rhosn +!-- if ground surface temperature +!-- is above freezing snow can melt from the bottom. the following !-- piece of code will check if bottom melting is possible. - IF(TSO(1).GT.273.15 .and. snhei > 0.) THEN - if (snhei.GT.deltsn+snth) then + if(tso(1).gt.273.15 .and. snhei > 0.) then + if (snhei.gt.deltsn+snth) then hsn = snhei - deltsn - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print*,'2 layer snow - snhei,hsn',snhei,hsn - ENDIF + endif else - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print*,'1 layer snow or blended - snhei',snhei - ENDIF + endif hsn = snhei endif - soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) - - SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & - RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 -! Egglston - empirical limit on snow melt from the bottom of snow pack - SMELTG=AMIN1(SMELTG, 5.8e-9) + soiltfrac=snowfrac*273.15+(1.-snowfrac)*tso(1) + + snohg=(tso(1)-soiltfrac)*(cap(1)*zshalf(2)+ & + rhocsn*0.5*hsn) / delt + snohg=amax1(0.,snohg) + snodif=0. + smeltg=snohg/xlmelt*1.e-3 +! egglston - empirical limit on snow melt from the bottom of snow pack + !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then + smeltg=amin1(smeltg, 5.8e-9) + endif ! rr - potential melting - rr=SNWE/delt - SMELTG=AMIN1(SMELTG, rr) - - SNOHGNEW=SMELTG*XLMELT*1.e3 - SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.266.and.j.eq.447) then - print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF - ENDIF + rr=snwe/delt + smeltg=amin1(smeltg, rr) + + snohgnew=smeltg*xlmelt*1.e3 + snodif=amax1(0.,(snohg-snohgnew)) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'tso(1),soiltfrac,smeltg,snodif',tso(1),soiltfrac,smeltg,snodif + endif -! snwe=max(0.,snwe-smeltg*delt*snowfrac) snwe=max(0.,snwe-smeltg*delt) - SNHEI=SNWE *1.E3 / RHOSN + snhei=snwe *1.e3 / rhosn + !-- add up all snow melt + smelt = smelt + smeltg - if(snhei > 0.) TSO(1) = soiltfrac - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.266.and.j.eq.447) then - print *,'Melt from the bottom snwe,snhei',snwe,snhei + if(snhei > 0.) tso(1) = soiltfrac + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'melt from the bottom snwe,snhei',snwe,snhei if (snhei==0.) & - print *,'Snow is all melted on the warm ground' - ENDIF + print *,'snow is all melted on the warm ground' + endif - ENDIF - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNHEI,SNOH',i,j,SNHEI,SNOH - ENDIF + endif + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snhei,snoh',i,j,snhei,snoh + endif ! & snweprint=snwe - snheiprint=snweprint*1.E3 / RHOSN + snheiprint=snweprint*1.e3 / rhosn - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *, 'snweprint : ',snweprint -print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB - ENDIF +print *, 'd9sn,soilt,tsob : ', d9sn,soilt,tsob + endif - X= (R21+D9SN*R22SN)*(soilt-TN) + & - XLVM*R210*(QSG-QGOLD) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNOWTEMP storage ',i,j,x - print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & - R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim - ENDIF + x= (r21+d9sn*r22sn)*(soilt-tn) + & + xlvm*r210*(qsg-qgold) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'snowtemp storage ',i,j,x + print *,'r21,d9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & + r21,d9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim + endif - X=X & + x=x & ! "heat" from snow and rain - -RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-SOILT) & - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + -rhonewcsn*newsnow/delt*(min(273.15,tabs)-soilt) & + -rainf*cvw*prcpms*(max(273.15,tabs)-soilt) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'x=',x - print *,'SNHEI=',snhei - print *,'SNFLX=',snflx - ENDIF + print *,'snhei=',snhei + print *,'snflx=',snflx + endif - IF(SNHEI.GT.0.) THEN + if(snhei.gt.0.) then if(ilnb.gt.1) then tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & + +(soilt1+tso(1))*(snhei-deltsn)) & -273.15 else tsnav=0.5*(soilt+tso(1)) - 273.15 endif - ELSE + else tsnav= soilt - 273.15 - ENDIF + endif !------------------------------------------------------------------------ - END SUBROUTINE SNOWTEMP + end subroutine snowtemp !------------------------------------------------------------------------ - SUBROUTINE SOILMOIST ( & + subroutine soilmoist ( & !--input parameters - DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & - ZSMAIN,ZSHALF,DIFFU,HYDRO, & - QSG,QVG,QCG,QCATM,QVATM,PRCP, & - QKMS,TRANSP,DRIP, & - DEW,SMELT,SOILICE,VEGFRAC,SNOWFRAC,soilres, & + delt,nzs,nddzs,dtdzs,dtdzs2,riw, & + zsmain,zshalf,diffu,hydro, & + qsg,qvg,qcg,qcatm,qvatm,prcp, & + qkms,transp,drip, & + dew,smelt,soilice,vegfrac,snowfrac,soilres, & !--soil properties - DQM,QMIN,REF,KSAT,RAS,INFMAX, & + dqm,qmin,ref,ksat,ras,infmax, & !--output - SOILMOIS,SOILIQW,MAVAIL,RUNOFF,RUNOFF2,INFILTRP) + soilmois,soiliqw,mavail,runoff,runoff2,infiltrp) !************************************************************************* -! moisture balance equation and Richards eqn. +! moisture balance equation and richards eqn. ! are solved here ! -! DELT - time step (s) -! IME,JME,NZS - dimensions of soil domain -! ZSMAIN - main levels in soil (m) -! ZSHALF - middle of the soil layers (m) -! DTDZS - dt/(2.*dzshalf*dzmain) -! DTDZS2 - dt/(2.*dzshalf) -! DIFFU - diffusional conductivity (m^2/s) -! HYDRO - hydraulic conductivity (m/s) -! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! delt - time step (s) +! ime,jme,nzs - dimensions of soil domain +! zsmain - main levels in soil (m) +! zshalf - middle of the soil layers (m) +! dtdzs - dt/(2.*dzshalf*dzmain) +! dtdzs2 - dt/(2.*dzshalf) +! diffu - diffusional conductivity (m^2/s) +! hydro - hydraulic conductivity (m/s) +! qsg,qvg,qcg - saturated mixing ratio, mixing ratio of ! water vapor and cloud at the ground ! surface, respectively (kg/kg) -! QCATM,QVATM - cloud and water vapor mixing ratio +! qcatm,qvatm - cloud and water vapor mixing ratio ! at the first atm. level (kg/kg) -! PRCP - precipitation rate in m/s -! QKMS - exchange coefficient for water vapor in the +! prcp - precipitation rate in m/s +! qkms - exchange coefficient for water vapor in the ! surface layer (m/s) -! TRANSP - transpiration from the soil layers (m/s) -! DRIP - liquid water dripping from the canopy to soil (m) -! DEW - dew in kg/m^2s -! SMELT - melting rate in m/s -! SOILICE - volumetric content of ice in soil (m^3/m^3) -! SOILIQW - volumetric content of liquid water in soil (m^3/m^3) -! VEGFRAC - greeness fraction (0-1) -! RAS - ration of air density to soil density -! INFMAX - maximum infiltration rate (kg/m^2/s) +! transp - transpiration from the soil layers (m/s) +! drip - liquid water dripping from the canopy to soil (m) +! dew - dew in kg/m^2s +! smelt - melting rate in m/s +! soilice - volumetric content of ice in soil (m^3/m^3) +! soiliqw - volumetric content of liquid water in soil (m^3/m^3) +! vegfrac - greeness fraction (0-1) +! ras - ration of air density to soil density +! infmax - maximum infiltration rate (kg/m^2/s) ! -! SOILMOIS - volumetric soil moisture, 6 levels (m^3/m^3) -! MAVAIL - fraction of maximum soil moisture in the top +! soilmois - volumetric soil moisture, 6 levels (m^3/m^3) +! mavail - fraction of maximum soil moisture in the top ! layer (0-1) -! RUNOFF - surface runoff (m/s) -! RUNOFF2 - underground runoff (m) -! INFILTRP - point infiltration flux into soil (m/s) +! runoff - surface runoff (m/s) +! runoff2 - underground runoff (m) +! infiltrp - point infiltration flux into soil (m/s) ! /(snow bottom runoff) (mm/s) ! -! COSMC, RHSMC - coefficients for implicit solution of -! Richards equation +! cosmc, rhsmc - coefficients for implicit solution of +! richards equation !****************************************************************** - IMPLICIT NONE + implicit none !------------------------------------------------------------------ !--- input variables - REAL, INTENT(IN ) :: DELT - INTEGER, INTENT(IN ) :: NZS,NDDZS + real, intent(in ) :: delt + integer, intent(in ) :: nzs,nddzs ! input variables - REAL, DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & - ZSHALF, & - DIFFU, & - HYDRO, & - TRANSP, & - SOILICE, & - DTDZS2 + real, dimension(1:nzs), intent(in ) :: zsmain, & + zshalf, & + diffu, & + hydro, & + transp, & + soilice, & + dtdzs2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real, dimension(1:nddzs), intent(in) :: dtdzs - REAL, INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM , & - QKMS,VEGFRAC,DRIP,PRCP , & - DEW,SMELT,SNOWFRAC , & - DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES + real, intent(in ) :: qsg,qvg,qcg,qcatm,qvatm , & + qkms,vegfrac,drip,prcp , & + dew,smelt,snowfrac , & + dqm,qmin,ref,ksat,ras,riw,soilres ! output - REAL, DIMENSION( 1:nzs ) , & + real, dimension( 1:nzs ) , & - INTENT(INOUT) :: SOILMOIS,SOILIQW + intent(inout) :: soilmois,soiliqw - REAL, INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & - INFMAX + real, intent(inout) :: mavail,runoff,runoff2,infiltrp, & + infmax ! local variables - REAL, DIMENSION( 1:nzs ) :: COSMC,RHSMC + real, dimension( 1:nzs ) :: cosmc,rhsmc - REAL :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 - REAL :: REFKDT,REFDK,DELT1,F1MAX,F2MAX - REAL :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX - REAL :: QQ,UMVEG,INFMAX1,TRANS - REAL :: TOTLIQ,FLX,FLXSAT,QTOT - REAL :: DID,X1,X2,X4,DENOM,Q2,Q4 - REAL :: dice,fcr,acrt,frzx,sum,cvfrz + real :: dzs,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10 + real :: refkdt,refdk,delt1,f1max,f2max + real :: f1,f2,fd,kdt,val,ddt,px,fk,fkmax + real :: qq,umveg,infmax1,trans + real :: totliq,flx,flxsat,qtot + real :: did,x1,x2,x4,denom,q2,q4 + real :: dice,fcr,acrt,frzx,sum,cvfrz - INTEGER :: NZS1,NZS2,K,KK,K1,KN,ialp1,jj,jk + integer :: nzs1,nzs2,k,kk,k1,kn,ialp1,jj,jk !****************************************************************************** -! COEFFICIENTS FOR THOMAS ALGORITHM FOR SOILMOIS +! coefficients for thomas algorithm for soilmois !****************************************************************************** - NZS1=NZS-1 - NZS2=NZS-2 + nzs1=nzs-1 + nzs2=nzs-2 - 118 format(6(10Pf23.19)) + 118 format(6(10pf23.19)) do k=1,nzs cosmc(k)=0. rhsmc(k)=0. enddo - DID=(ZSMAIN(NZS)-ZSHALF(NZS)) - X1=ZSMAIN(NZS)-ZSMAIN(NZS1) - -!7may09 DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2. -! DENOM=DID/DELT+DIFFU(NZS1)/X1 -! COSMC(1)=DIFFU(NZS1)/X1/DENOM -! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT -! 1 +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) -! 1 -HYDRO(NZS1)*SOILMOIS(NZS1))*DID -! 1 /X1) /DENOM - - DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & - +HYDRO(NZS1)/2./DID)/DENOM - RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & - DID)/DENOM - -! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT & -! +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) & -! -HYDRO(NZS1)*SOILMOIS(NZS1))*DID & -! /X1) /DENOM - -!12 June 2014 - low boundary condition: 1 - zero diffusion below the lowest + did=(zsmain(nzs)-zshalf(nzs)) + x1=zsmain(nzs)-zsmain(nzs1) + +!7may09 did=(zsmain(nzs)-zshalf(nzs))*2. +! denom=did/delt+diffu(nzs1)/x1 +! cosmc(1)=diffu(nzs1)/x1/denom +! rhsmc(1)=(soilmois(nzs)*did/delt +! 1 +transp(nzs)-(hydro(nzs)*soilmois(nzs) +! 1 -hydro(nzs1)*soilmois(nzs1))*did +! 1 /x1) /denom + + denom=(1.+diffu(nzs1)/x1/did*delt+hydro(nzs)/(2.*did)*delt) + cosmc(1)=delt*(diffu(nzs1)/did/x1 & + +hydro(nzs1)/2./did)/denom + rhsmc(1)=(soilmois(nzs)+transp(nzs)*delt/ & + did)/denom + +! rhsmc(1)=(soilmois(nzs)*did/delt & +! +transp(nzs)-(hydro(nzs)*soilmois(nzs) & +! -hydro(nzs1)*soilmois(nzs1))*did & +! /x1) /denom + +!12 june 2014 - low boundary condition: 1 - zero diffusion below the lowest ! level; 2 - soil moisture at the low boundary can be lost due to the root uptake. -! So far - no interaction with the water table. - - DENOM=1.+DIFFU(nzs1)/X1/DID*DELT -!orig DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/DID*DELT) -!orig COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & -!orig +HYDRO(NZS1)/2./DID)/DENOM - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & - +HYDRO(NZS1)/DID)/DENOM - -! RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & -! DID)/DENOM - - RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & - +TRANSP(NZS)*DELT/DID)/DENOM -!test RHSMC(1)=SOILMOIS(NZS)-HYDRO(NZS)*soilmois(nzs) - -!test!!! -!this test gave smoother soil moisture, ovwerall better results - COSMC(1)=0. - RHSMC(1)=SOILMOIS(NZS) +! so far - no interaction with the water table. + + denom=1.+diffu(nzs1)/x1/did*delt + cosmc(1)=delt*(diffu(nzs1)/did/x1 & + +hydro(nzs1)/did)/denom + rhsmc(1)=(soilmois(nzs)-hydro(nzs)*delt/did*soilmois(nzs) & + +transp(nzs)*delt/did)/denom + cosmc(1)=0. + rhsmc(1)=soilmois(nzs) ! - DO 330 K=1,NZS2 - KN=NZS-K - K1=2*KN-3 - X4=2.*DTDZS(K1)*DIFFU(KN-1) - X2=2.*DTDZS(K1+1)*DIFFU(KN) - Q4=X4+HYDRO(KN-1)*DTDZS2(KN-1) - Q2=X2-HYDRO(KN+1)*DTDZS2(KN-1) - DENOM=1.+X2+X4-Q2*COSMC(K) - COSMC(K+1)=Q4/DENOM - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & - ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k - ENDIF - 330 RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & - +TRANSP(KN) & - /(ZSHALF(KN+1)-ZSHALF(KN)) & - *DELT)/DENOM - -! --- MOISTURE BALANCE BEGINS HERE - - TRANS=TRANSP(1) - UMVEG=(1.-VEGFRAC)*soilres - - RUNOFF=0. - RUNOFF2=0. - DZS=ZSMAIN(2) - R1=COSMC(NZS1) - R2= RHSMC(NZS1) - R3=DIFFU(1)/DZS - R4=R3+HYDRO(1)*.5 - R5=R3-HYDRO(2)*.5 - R6=QKMS*RAS -!-- Total liquid water available on the top of soil domain -!-- Without snow - 3 sources of water: precipitation, + do 330 k=1,nzs2 + kn=nzs-k + k1=2*kn-3 + x4=2.*dtdzs(k1)*diffu(kn-1) + x2=2.*dtdzs(k1+1)*diffu(kn) + q4=x4+hydro(kn-1)*dtdzs2(kn-1) + q2=x2-hydro(kn+1)*dtdzs2(kn-1) + denom=1.+x2+x4-q2*cosmc(k) + cosmc(k+1)=q4/denom + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'q2,soilmois(kn),diffu(kn),x2,hydro(kn+1),dtdzs2(kn-1),kn,k' & + ,q2,soilmois(kn),diffu(kn),x2,hydro(kn+1),dtdzs2(kn-1),kn,k + endif + 330 rhsmc(k+1)=(soilmois(kn)+q2*rhsmc(k) & + +transp(kn) & + /(zshalf(kn+1)-zshalf(kn)) & + *delt)/denom + +! --- moisture balance begins here + + trans=transp(1) + umveg=(1.-vegfrac)*soilres + + runoff=0. + runoff2=0. + dzs=zsmain(2) + r1=cosmc(nzs1) + r2= rhsmc(nzs1) + r3=diffu(1)/dzs + r4=r3+hydro(1)*.5 + r5=r3-hydro(2)*.5 + r6=qkms*ras +!-- total liquid water available on the top of soil domain +!-- without snow - 3 sources of water: precipitation, !-- water dripping from the canopy and dew -!-- With snow - only one source of water - snow melt +!-- with snow - only one source of water - snow melt 191 format (f23.19) -! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - - TOTLIQ=PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & - UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT - ENDIF +! totliq=umveg*prcp-drip/delt-umveg*dew*ras-smelt -!test 16 may TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT -!30july13 TOTLIQ=UMVEG*PRCP-DRIP/DELT-SMELT + totliq=prcp-drip/delt-umveg*dew*ras-smelt + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then +print *,'umveg*prcp,drip/delt,umveg*dew*ras,smelt', & + umveg*prcp,drip/delt,umveg*dew*ras,smelt + endif - FLX=TOTLIQ - INFILTRP=TOTLIQ + flx=totliq + infiltrp=totliq -! ----------- FROZEN GROUND VERSION ------------------------- -! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF -! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. -! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. -! BASED ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT -! CLOSE TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. -! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) +! ----------- frozen ground version ------------------------- +! reference frozen ground parameter, cvfrz, is a shape parameter of +! areal distribution function of soil ice content which equals 1/cv. +! cv is a coefficient of spatial variation of soil ice content. +! based on field data cv depends on areal mean of frozen depth, and it +! close to constant = 0.6 if areal mean frozen depth is above 20 cm. +! that is why parameter cvfrz = 3 (int{1/0.6*0.6}) ! -! Current logic doesn't allow CVFRZ be bigger than 3 - CVFRZ = 3. - -!-- SCHAAKE/KOREN EXPRESSION for calculation of max infiltration - REFKDT=3. - REFDK=3.4341E-6 - DELT1=DELT/86400. - F1MAX=DQM*ZSHALF(2) - F2MAX=DQM*(ZSHALF(3)-ZSHALF(2)) - F1=F1MAX*(1.-SOILMOIS(1)/DQM) - DICE=SOILICE(1)*ZSHALF(2) - FD=F1 +! current logic doesn't allow cvfrz be bigger than 3 + cvfrz = 3. + +!-- schaake/koren expression for calculation of max infiltration + refkdt=3. + refdk=3.4341e-6 + delt1=delt/86400. + f1max=dqm*zshalf(2) + f2max=dqm*(zshalf(3)-zshalf(2)) + f1=f1max*(1.-soilmois(1)/dqm) + dice=soilice(1)*zshalf(2) + fd=f1 do k=2,nzs1 - DICE=DICE+(ZSHALF(k+1)-ZSHALF(k))*SOILICE(K) - FKMAX=DQM*(ZSHALF(k+1)-ZSHALF(k)) - FK=FKMAX*(1.-SOILMOIS(k)/DQM) - FD=FD+FK + dice=dice+(zshalf(k+1)-zshalf(k))*soilice(k) + fkmax=dqm*(zshalf(k+1)-zshalf(k)) + fk=fkmax*(1.-soilmois(k)/dqm) + fd=fd+fk enddo - KDT=REFKDT*KSAT/REFDK - VAL=(1.-EXP(-KDT*DELT1)) - DDT = FD*VAL - PX= - TOTLIQ * DELT - IF(PX.LT.0.0) PX = 0.0 - IF(PX.gt.0.0) THEN - INFMAX1 = (PX*(DDT/(PX+DDT)))/DELT - ELSE - INFMAX1 = 0. - ENDIF - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'INFMAX1 before frozen part',INFMAX1 - ENDIF + kdt=refkdt*ksat/refdk + val=(1.-exp(-kdt*delt1)) + ddt = fd*val + px= - totliq * delt + if(px.lt.0.0) px = 0.0 + if(px.gt.0.0) then + infmax1 = (px*(ddt/(px+ddt)))/delt + else + infmax1 = 0. + endif + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'infmax1 before frozen part',infmax1 + endif -! ----------- FROZEN GROUND VERSION -------------------------- -! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ----------- frozen ground version -------------------------- +! reduction of infiltration based on frozen ground parameters ! ! ------------------------------------------------------------------ - FRZX= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468) - FCR = 1. - IF ( DICE .GT. 1.E-2) THEN - ACRT = CVFRZ * FRZX / DICE - SUM = 1. - IALP1 = CVFRZ - 1 - DO JK = 1,IALP1 - K = 1 - DO JJ = JK+1, IALP1 - K = K * JJ - END DO - SUM = SUM + (ACRT ** ( CVFRZ-JK)) / FLOAT (K) - END DO - FCR = 1. - EXP(-ACRT) * SUM - END IF - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'FCR--------',fcr - print *,'DICE=',dice - ENDIF - INFMAX1 = INFMAX1* FCR + frzx= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468) + fcr = 1. + if ( dice .gt. 1.e-2) then + acrt = cvfrz * frzx / dice + sum = 1. + ialp1 = cvfrz - 1 + do jk = 1,ialp1 + k = 1 + do jj = jk+1, ialp1 + k = k * jj + end do + sum = sum + (acrt ** ( cvfrz-jk)) / float (k) + end do + fcr = 1. - exp(-acrt) * sum + end if + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'fcr--------',fcr + print *,'dice=',dice + endif + infmax1 = infmax1* fcr ! ------------------------------------------------------------------- - INFMAX = MAX(INFMAX1,HYDRO(1)*SOILMOIS(1)) - INFMAX = MIN(INFMAX, -TOTLIQ) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & - INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ - ENDIF + infmax = max(infmax1,hydro(1)*soilmois(1)) + infmax = min(infmax, -totliq) + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then +print *,'infmax,infmax1,hydro(1)*soiliqw(1),-totliq', & + infmax,infmax1,hydro(1)*soiliqw(1),-totliq + endif !---- - IF (-TOTLIQ.GT.INFMAX)THEN - RUNOFF=-TOTLIQ-INFMAX - FLX=-INFMAX - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'FLX,RUNOFF1=',flx,runoff - ENDIF - ENDIF -! INFILTRP is total infiltration flux in M/S - INFILTRP=FLX -! Solution of moisture budget - R7=.5*DZS/DELT - R4=R4+R7 - FLX=FLX-SOILMOIS(1)*R7 -! R8 is for direct evaporation from soil, which occurs + if (-totliq.gt.infmax)then + runoff=-totliq-infmax + flx=-infmax + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'flx,runoff1=',flx,runoff + endif + endif +! infiltrp is total infiltration flux in m/s + infiltrp=flx +! solution of moisture budget + r7=.5*dzs/delt + r4=r4+r7 + flx=flx-soilmois(1)*r7 +! r8 is for direct evaporation from soil, which occurs ! only from snow-free areas -! R8=UMVEG*R6 - R8=UMVEG*R6*(1.-snowfrac) - QTOT=QVATM+QCATM - R9=TRANS - R10=QTOT-QSG +! r8=umveg*r6 + r8=umveg*r6*(1.-snowfrac) + qtot=qvatm+qcatm + r9=trans + r10=qtot-qsg !-- evaporation regime - IF(R10.LE.0.) THEN - QQ=(R5*R2-FLX+R9)/(R4-R5*R1-R10*R8/(REF-QMIN)) - FLXSAT=-DQM*(R4-R5*R1-R10*R8/(REF-QMIN)) & - +R5*R2+R9 - ELSE + if(r10.le.0.) then + qq=(r5*r2-flx+r9)/(r4-r5*r1-r10*r8/(ref-qmin)) + flxsat=-dqm*(r4-r5*r1-r10*r8/(ref-qmin)) & + +r5*r2+r9 + else !-- dew formation regime - QQ=(R2*R5-FLX+R8*(QTOT-QCG-QVG)+R9)/(R4-R1*R5) - FLXSAT=-DQM*(R4-R1*R5)+R2*R5+R8*(QTOT-QVG-QCG)+R9 - END IF + qq=(r2*r5-flx+r8*(qtot-qcg-qvg)+r9)/(r4-r1*r5) + flxsat=-dqm*(r4-r1*r5)+r2*r5+r8*(qtot-qvg-qcg)+r9 + end if - IF(QQ.LT.0.) THEN -! print *,'negative QQ=',qq - SOILMOIS(1)=1.e-8 + if(qq.lt.0.) then +! print *,'negative qq=',qq + soilmois(1)=1.e-8 - ELSE IF(QQ.GT.DQM) THEN + else if(qq.gt.dqm) then !-- saturation - SOILMOIS(1)=DQM - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'FLXSAT,FLX,DELT',FLXSAT,FLX,DELT,RUNOFF2 - ENDIF -! RUNOFF2=(FLXSAT-FLX) - RUNOFF=RUNOFF+(FLXSAT-FLX) - ELSE - SOILMOIS(1)=min(dqm,max(1.e-8,QQ)) - END IF - - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw - print *,'COSMC,RHSMC',COSMC,RHSMC - ENDIF -!--- FINAL SOLUTION FOR SOILMOIS -! DO K=2,NZS1 - DO K=2,NZS - KK=NZS-K+1 - QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) -! QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK) - - IF (QQ.LT.0.) THEN -! print *,'negative QQ=',qq - SOILMOIS(K)=1.e-8 - - ELSE IF(QQ.GT.DQM) THEN + soilmois(1)=dqm + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'flxsat,flx,delt',flxsat,flx,delt,runoff2 + endif +! runoff2=(flxsat-flx) + runoff=runoff+(flxsat-flx) + else + soilmois(1)=min(dqm,max(1.e-8,qq)) + end if + + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'soilmois,soiliqw, soilice',soilmois,soiliqw,soilice*riw + print *,'cosmc,rhsmc',cosmc,rhsmc + endif +!--- final solution for soilmois +! do k=2,nzs1 + do k=2,nzs + kk=nzs-k+1 + qq=cosmc(kk)*soilmois(k-1)+rhsmc(kk) +! qq=cosmc(kk)*soiliqw(k-1)+rhsmc(kk) + + if (qq.lt.0.) then +! print *,'negative qq=',qq + soilmois(k)=1.e-8 + + else if(qq.gt.dqm) then !-- saturation - SOILMOIS(K)=DQM - IF(K.EQ.NZS)THEN - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'hydro(k),QQ,DQM,k',hydro(k),QQ,DQM,k - ENDIF - RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)))/DELT -! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) -! print *,'RUNOFF2=',RUNOFF2 - ELSE -! print *,'QQ,DQM,k',QQ,DQM,k - RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)))/DELT -! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) - ENDIF - ELSE - SOILMOIS(K)=min(dqm,max(1.e-8,QQ)) - END IF - END DO - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw - ENDIF + soilmois(k)=dqm + if(k.eq.nzs)then + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'hydro(k),qq,dqm,k',hydro(k),qq,dqm,k + endif + runoff2=runoff2+((qq-dqm)*(zsmain(k)-zshalf(k)))/delt + else + runoff2=runoff2+((qq-dqm)*(zshalf(k+1)-zshalf(k)))/delt + endif + else + soilmois(k)=min(dqm,max(1.e-8,qq)) + end if + end do + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'end soilmois,soiliqw,soilice',soilmois,soiliqw,soilice*riw + endif -! RUNOFF2=RUNOFF2+hydro(nzs)*SOILMOIS(NZS) -! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM)) -! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN))) - MAVAIL=max(.00001,min(1.,(SOILMOIS(1)/(REF-QMIN)*(1.-snowfrac)+1.*snowfrac))) + mavail=max(.00001,min(1.,(soilmois(1)/(ref-qmin)*(1.-snowfrac)+1.*snowfrac))) -! RETURN -! END +! return +! end !------------------------------------------------------------------- - END SUBROUTINE SOILMOIST + end subroutine soilmoist !------------------------------------------------------------------- - SUBROUTINE SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & + subroutine soilprop(spp_lsm,rstochcol,fieldcol_sf, & !--- input variables nzs,fwsat,lwsat,tav,keepfr, & soilmois,soiliqw,soilice, & soilmoism,soiliqwm,soilicem, & !--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & + qwrtz,rhocs,dqm,qmin,psis,bclh,ksat, & !--- constants - riw,xlmelt,CP,G0_P,cvw,ci, & + riw,xlmelt,cp,g0_p,cvw,ci, & kqwrtz,kice,kwt, & !--- output variables thdif,diffu,hydro,cap) !****************************************************************** -! SOILPROP computes thermal diffusivity, and diffusional and +! soilprop computes thermal diffusivity, and diffusional and ! hydraulic condeuctivities !****************************************************************** -! NX,NY,NZS - dimensions of soil domain -! FWSAT, LWSAT - volumetric content of frozen and liquid water +! nx,ny,nzs - dimensions of soil domain +! fwsat, lwsat - volumetric content of frozen and liquid water ! for saturated condition at given temperatures (m^3/m^3) -! TAV - temperature averaged for soil layers (K) -! SOILMOIS - volumetric soil moisture at the main soil levels (m^3/m^3) -! SOILMOISM - volumetric soil moisture averaged for layers (m^3/m^3) -! SOILIQWM - volumetric liquid soil moisture averaged for layers (m^3/m^3) -! SOILICEM - volumetric content of soil ice averaged for layers (m^3/m^3) -! THDIF - thermal diffusivity for soil layers (W/m/K) -! DIFFU - diffusional conductivity (m^2/s) -! HYDRO - hydraulic conductivity (m/s) -! CAP - volumetric heat capacity (J/m^3/K) +! tav - temperature averaged for soil layers (k) +! soilmois - volumetric soil moisture at the main soil levels (m^3/m^3) +! soilmoism - volumetric soil moisture averaged for layers (m^3/m^3) +! soiliqwm - volumetric liquid soil moisture averaged for layers (m^3/m^3) +! soilicem - volumetric content of soil ice averaged for layers (m^3/m^3) +! thdif - thermal diffusivity for soil layers (w/m/k) +! diffu - diffusional conductivity (m^2/s) +! hydro - hydraulic conductivity (m/s) +! cap - volumetric heat capacity (j/m^3/k) ! !****************************************************************** - IMPLICIT NONE + implicit none !----------------------------------------------------------------- !--- soil properties - INTEGER, INTENT(IN ) :: NZS - REAL , & - INTENT(IN ) :: RHOCS, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QWRTZ, & - QMIN - - REAL, DIMENSION( 1:nzs ) , & - INTENT(IN ) :: SOILMOIS, & + integer, intent(in ) :: nzs + real , & + intent(in ) :: rhocs, & + bclh, & + dqm, & + ksat, & + psis, & + qwrtz, & + qmin + + real, dimension( 1:nzs ) , & + intent(in ) :: soilmois, & keepfr - REAL, INTENT(IN ) :: CP, & - CVW, & - RIW, & + real, intent(in ) :: cp, & + cvw, & + riw, & kqwrtz, & kice, & kwt, & - XLMELT, & - G0_P + xlmelt, & + g0_p - REAL, DIMENSION(1:NZS), INTENT(IN) :: rstochcol - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: fieldcol_sf - INTEGER, INTENT(IN ) :: spp_lsm + real, dimension(1:nzs), intent(in) :: rstochcol + real, dimension(1:nzs), intent(inout) :: fieldcol_sf + integer, intent(in ) :: spp_lsm !--- output variables - REAL, DIMENSION(1:NZS) , & - INTENT(INOUT) :: cap,diffu,hydro , & + real, dimension(1:nzs) , & + intent(inout) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & soiliqw,soilice , & @@ -6121,19 +6164,19 @@ SUBROUTINE SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & fwsat,lwsat !--- local variables - REAL, DIMENSION(1:NZS) :: hk,detal,kasat,kjpl + real, dimension(1:nzs) :: hk,detal,kasat,kjpl - REAL :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci - REAL :: tln,tavln,tn,pf,a,am,ame,h - INTEGER :: nzs1,k + real :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci + real :: tln,tavln,tn,pf,a,am,ame,h + integer :: nzs1,k -!-- for Johansen thermal conductivity - REAL :: kzero,gamd,kdry,kas,x5,sr,ke +!-- for johansen thermal conductivity + real :: kzero,gamd,kdry,kas,x5,sr,ke nzs1=nzs-1 -!-- Constants for Johansen (1975) thermal conductivity +!-- constants for johansen (1975) thermal conductivity kzero =2. ! if qwrtz > 0.2 @@ -6148,44 +6191,49 @@ SUBROUTINE SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & x1=xlmelt/(g0_p*psis) x2=x1/bclh*ws x4=(bclh+1.)/bclh -!--- Next 3 lines are for Johansen thermal conduct. +!--- next 3 lines are for johansen thermal conduct. gamd=(1.-ws)*2700. kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd) + !-- one more option from christa's paper + if(qwrtz > 0.2) then kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) + else + kas=kqwrtz**qwrtz*3.**(1.-qwrtz) + endif - DO K=1,NZS1 + do k=1,nzs1 tn=tav(k) - 273.15 wd=ws - riw*soilicem(k) psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh & * (ws/wd)**3. -!--- PSIF should be in [CM] to compute PF +!--- psif should be in [cm] to compute pf pf=log10(abs(psif)) fact=1.+riw*soilicem(k) -!--- HK is for McCumber thermal conductivity - IF(PF.LE.5.2) THEN - HK(K)=420.*EXP(-(PF+2.7))*fact - ELSE - HK(K)=.1744*fact - END IF - - IF(soilicem(k).NE.0.AND.TN.LT.0.) then -!--- DETAL is taking care of energy spent on freezing or released from +!--- hk is for mccumber thermal conductivity + if(pf.le.5.2) then + hk(k)=420.*exp(-(pf+2.7))*fact + else + hk(k)=.1744*fact + end if + + if(soilicem(k).ne.0.and.tn.lt.0.) then +!--- detal is taking care of energy spent on freezing or released from ! melting of soil water - DETAL(K)=273.15*X2/(TAV(K)*TAV(K))* & - (TAV(K)/(X1*TN))**X4 + detal(k)=273.15*x2/(tav(k)*tav(k))* & + (tav(k)/(x1*tn))**x4 if(keepfr(k).eq.1.) then detal(k)=0. endif - ENDIF + endif -!--- Next 10 lines calculate Johansen thermal conductivity KJPL +!--- next 10 lines calculate johansen thermal conductivity kjpl kasat(k)=kas**(1.-ws)*kice**fwsat(k) & *kwt**lwsat(k) - X5=(soilmoism(k)+qmin)/ws + x5=(soilmoism(k)+qmin)/ws if(soilicem(k).eq.0.) then sr=max(0.101,x5) ke=log10(sr)+1. @@ -6198,43 +6246,39 @@ SUBROUTINE SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & kjpl(k)=ke*(kasat(k)-kdry)+kdry -!--- CAP -volumetric heat capacity - CAP(K)=(1.-WS)*RHOCS & - + (soiliqwm(K)+qmin)*CVW & - + soilicem(K)*CI & - + (dqm-soilmoism(k))*CP*1.2 & - - DETAL(K)*1.e3*xlmelt +!--- cap -volumetric heat capacity + cap(k)=(1.-ws)*rhocs & + + (soiliqwm(k)+qmin)*cvw & + + soilicem(k)*ci & + + (dqm-soilmoism(k))*cp*1.2 & + - detal(k)*1.e3*xlmelt - a=RIW*soilicem(K) + a=riw*soilicem(k) if((ws-a).lt.0.12)then - diffu(K)=0. + diffu(k)=0. else - H=max(0.,(soilmoism(K)-a)/(max(1.e-8,(dqm-a)))) + h=max(0.,(soilmoism(k)+qmin-a)/(max(1.e-8,(ws-a)))) facd=1. - if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) - ame=max(1.e-8,dqm-riw*soilicem(K)) -!--- DIFFU is diffusional conductivity of soil water - diffu(K)=-BCLH*KSAT*PSIS/ame* & - (dqm/ame)**3. & - *H**(BCLH+2.)*facd + if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(k)) + ame=max(1.e-8,ws-riw*soilicem(k)) +!--- diffu is diffusional conductivity of soil water + diffu(k)=-bclh*ksat*psis/ame* & + (ws/ame)**3. & + *h**(bclh+2.)*facd endif -! diffu(K)=-BCLH*KSAT*PSIS/dqm & -! *H**(BCLH+2.) - - !--- thdif - thermal diffusivity -! thdif(K)=HK(K)/CAP(K) -!--- Use thermal conductivity from Johansen (1975) - thdif(K)=KJPL(K)/CAP(K) +! thdif(k)=hk(k)/cap(k) +!--- use thermal conductivity from johansen (1975) + thdif(k)=kjpl(k)/cap(k) - END DO + end do - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'soilice*riw,soiliqw,soilmois,ws',soilice*riw,soiliqw,soilmois,ws - ENDIF - DO K=1,NZS + endif + do k=1,nzs if((ws-riw*soilice(k)).lt.0.12)then hydro(k)=0. @@ -6242,23 +6286,23 @@ SUBROUTINE SOILPROP(spp_lsm,rstochcol,fieldcol_sf, & fach=1. if(soilice(k).ne.0.) & fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) - am=max(1.e-8,dqm-riw*soilice(k)) -!--- HYDRO is hydraulic conductivity of soil water - hydro(K)=min(KSAT,KSAT/am* & - (soiliqw(K)/am) & - **(2.*BCLH+2.) & + am=max(1.e-8,ws-riw*soilice(k)) +!--- hydro is hydraulic conductivity of soil water + hydro(k)=min(ksat,ksat/am* & + (soiliqw(k)/am) & + **(2.*bclh+2.) & * fach) if(hydro(k)<1.e-10)hydro(k)=0. endif - ENDDO + enddo !----------------------------------------------------------------------- - END SUBROUTINE SOILPROP + end subroutine soilprop !----------------------------------------------------------------------- - SUBROUTINE TRANSF(i,j, & + subroutine transf(i,j, & !--- input variables nzs,nroot,soiliqw,tabs,lai,gswin, & !--- soil fixed fields @@ -6267,46 +6311,46 @@ SUBROUTINE TRANSF(i,j, & tranf,transum) !------------------------------------------------------------------- -!--- TRANF(K) - THE TRANSPIRATION FUNCTION (Smirnova et al. 1996, EQ. 18,19) +!--- tranf(k) - the transpiration function (Smirnova et al. 1996, eq. 18,19) !******************************************************************* -! NX,NY,NZS - dimensions of soil domain -! SOILIQW - volumetric liquid soil moisture at the main levels (m^3/m^3) -! TRANF - the transpiration function at levels (m) -! TRANSUM - transpiration function integrated over the rooting zone (m) +! nx,ny,nzs - dimensions of soil domain +! soiliqw - volumetric liquid soil moisture at the main levels (m^3/m^3) +! tranf - the transpiration function at levels (m) +! transum - transpiration function integrated over the rooting zone (m) ! !******************************************************************* - IMPLICIT NONE + implicit none !------------------------------------------------------------------- !--- input variables - INTEGER, INTENT(IN ) :: i,j,nroot,nzs, iland + integer, intent(in ) :: i,j,nroot,nzs, iland - REAL , & - INTENT(IN ) :: GSWin, TABS, lai + real , & + intent(in ) :: gswin, tabs, lai !--- soil properties - REAL , & - INTENT(IN ) :: DQM, & - QMIN, & - REF, & - PC, & - WILT + real , & + intent(in ) :: dqm, & + qmin, & + ref, & + pc, & + wilt - REAL, DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & - ZSHALF + real, dimension(1:nzs), intent(in) :: soiliqw, & + zshalf !-- output - REAL, DIMENSION(1:NZS), INTENT(OUT) :: TRANF - REAL, INTENT(OUT) :: TRANSUM + real, dimension(1:nzs), intent(out) :: tranf + real, intent(out) :: transum !-- local variables - REAL :: totliq, did - INTEGER :: k + real :: totliq, did + integer :: k !-- for non-linear root distribution - REAL :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 - REAL :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd - REAL, DIMENSION(1:NZS) :: PART + real :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 + real :: ftem, pctot, fsol, f1, cmin, cmax, totcnd + real, dimension(1:nzs) :: part !-------------------------------------------------------------------- do k=1,nzs @@ -6330,19 +6374,19 @@ SUBROUTINE TRANSF(i,j, & if(totliq.le.0.) gx=0. if(gx.gt.1.) gx=1. if(gx.lt.0.) gx=0. - DID=zshalf(2) - part(1)=DID*gx - IF(TOTLIQ.GT.REF) THEN - TRANF(1)=DID - ELSE IF(TOTLIQ.LE.WILT) THEN - TRANF(1)=0. - ELSE - TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID - ENDIF + did=zshalf(2) + part(1)=did*gx + if(totliq.gt.ref) then + tranf(1)=did + else if(totliq.le.wilt) then + tranf(1)=0. + else + tranf(1)=(totliq-wilt)/(ref-wilt)*did + endif !-- uncomment next line for non-linear root distribution -! TRANF(1)=part(1) +! tranf(1)=part(1) - DO K=2,NROOT + do k=2,nroot totliq=soiliqw(k)+qmin sm1=totliq sm2=sm1*sm1 @@ -6353,55 +6397,53 @@ SUBROUTINE TRANSF(i,j, & if(totliq.le.0.) gx=0. if(gx.gt.1.) gx=1. if(gx.lt.0.) gx=0. - DID=zshalf(K+1)-zshalf(K) + did=zshalf(k+1)-zshalf(k) part(k)=did*gx - IF(totliq.GE.REF) THEN - TRANF(K)=DID - ELSE IF(totliq.LE.WILT) THEN - TRANF(K)=0. - ELSE - TRANF(K)=(totliq-WILT) & - /(REF-WILT)*DID - ENDIF + if(totliq.ge.ref) then + tranf(k)=did + else if(totliq.le.wilt) then + tranf(k)=0. + else + tranf(k)=(totliq-wilt) & + /(ref-wilt)*did + endif !-- uncomment next line for non-linear root distribution -! TRANF(k)=part(k) - END DO +! tranf(k)=part(k) + end do -! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) +! for lai> 3 => transpiration at potential rate (f.tardieu, 2013) if(lai > 4.) then pctot=0.8 else pctot=pc -!- 26aug16- next 2 lines could lead to LH increase and higher 2-m Q during the day +!- 26aug16- next 2 lines could lead to lh increase and higher 2-m q during the day ! pctot=min(0.8,pc*lai) ! pctot=min(0.8,max(pc,pc*lai)) endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if (i==421.and.j==280) then + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'i,j,pctot,lai,pc',i,j,pctot,lai,pc - ENDIF + endif !--- !--- air temperature function -! Avissar (1985) and AX 7/95 - IF (TABS .LE. 302.15) THEN - FTEM = 1.0 / (1.0 + EXP(-0.41 * (TABS - 282.05))) - ELSE - FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0))) - ENDIF - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if (i==421.and.j==280) then +! Avissar (1985) and Ax 7/95 + if (tabs .le. 302.15) then + ftem = 1.0 / (1.0 + exp(-0.41 * (tabs - 282.05))) + else + ftem = 1.0 / (1.0 + exp(0.5 * (tabs - 314.0))) + endif + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then print *,'i,j,tabs,ftem',i,j,tabs,ftem - ENDIF + endif !--- incoming solar function cmin = 1./rsmax_data cmax = 1./rstbl(iland) if(lai > 1.) then cmax = lai/rstbl(iland) ! max conductance endif -! Noihlan & Planton (1988) +! noihlan & planton (1988) f1=0. ! if(lai > 0.01) then -! f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when GSWin=0. +! f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when gswin=0. ! fsol = (f1+cmin/cmax)/(1.+f1) ! fsol=min(1.,fsol) ! else @@ -6409,745 +6451,705 @@ SUBROUTINE TRANSF(i,j, & ! endif ! totcnd = max(lai/rstbl(iland), pctot * ftem * f1) ! Mahrer & Avissar (1982), Avissar et al. (1985) - if (GSWin < rgltbl(iland)) then - fsol = 1. / (1. + exp(-0.034 * (GSWin - 3.5))) + if (gswin < rgltbl(iland)) then + fsol = 1. / (1. + exp(-0.034 * (gswin - 3.5))) else fsol = 1. endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if (i==421.and.j==280) then - print *,'i,j,GSWin,lai,f1,fsol',i,j,gswin,lai,f1,fsol - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'i,j,gswin,lai,f1,fsol',i,j,gswin,lai,f1,fsol + endif !--- total conductance totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if (i==421.and.j==280) then - print *,'i,j,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & - ,i,j,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd - ENDIF + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'i,j,iland,rgltbl(iland),rstbl(iland),rsmax_data,totcnd' & + ,i,j,iland,rgltbl(iland),rstbl(iland),rsmax_data,totcnd + endif -!-- TRANSUM - total for the rooting zone +!-- transum - total for the rooting zone transum=0. - DO K=1,NROOT + do k=1,nroot ! linear root distribution - TRANF(k)=max(cmin,TRANF(k)*totcnd) + tranf(k)=max(cmin,tranf(k)*totcnd) transum=transum+tranf(k) - END DO - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if (i==421.and.j==280) then - print *,'i,j,transum,TRANF',i,j,transum,tranf + end do + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then + print *,'i,j,transum,tranf',i,j,transum,tranf endif !----------------------------------------------------------------- - END SUBROUTINE TRANSF + end subroutine transf !----------------------------------------------------------------- - SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) + subroutine vilka(tn,d1,d2,pp,qs,ts,tt,nstep,ii,j,iland,isoil) !-------------------------------------------------------------- -!--- VILKA finds the solution of energy budget at the surface -!--- using table T,QS computed from Clausius-Klapeiron +!--- vilka finds the solution of energy budget at the surface +!--- using table t,qs computed from clausius-klapeiron !-------------------------------------------------------------- - REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP - INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil + real, dimension(1:5001), intent(in ) :: tt + real, intent(in ) :: tn,d1,d2,pp + integer, intent(in ) :: nstep,ii,j,iland,isoil - REAL, INTENT(OUT ) :: QS, TS + real, intent(out ) :: qs, ts - REAL :: F1,T1,T2,RN - INTEGER :: I,I1 + real :: f1,t1,t2,rn + integer :: i,i1 - I=(TN-1.7315E2)/.05+1 - T1=173.1+FLOAT(I)*.05 - F1=T1+D1*TT(I)-D2 - I1=I-F1/(.05+D1*(TT(I+1)-TT(I))) - I=I1 - IF(I.GT.5000.OR.I.LT.1) GOTO 1 - 10 I1=I - T1=173.1+FLOAT(I)*.05 - F1=T1+D1*TT(I)-D2 - RN=F1/(.05+D1*(TT(I+1)-TT(I))) - I=I-INT(RN) - IF(I.GT.5000.OR.I.LT.1) GOTO 1 - IF(I1.NE.I) GOTO 10 - TS=T1-.05*RN - QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP - GOTO 20 -! 1 PRINT *,'Crash in surface energy budget - STOP' - 1 PRINT *,' AVOST IN VILKA Table index= ',I -! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil - print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn - CALL wrf_error_fatal (' Crash in surface energy budget ' ) - 20 CONTINUE + i=(tn-1.7315e2)/.05+1 + t1=173.1+float(i)*.05 + f1=t1+d1*tt(i)-d2 + i1=i-f1/(.05+d1*(tt(i+1)-tt(i))) + i=i1 + if(i.gt.5000.or.i.lt.1) goto 1 + 10 i1=i + t1=173.1+float(i)*.05 + f1=t1+d1*tt(i)-d2 + rn=f1/(.05+d1*(tt(i+1)-tt(i))) + i=i-int(rn) + if(i.gt.5000.or.i.lt.1) goto 1 + if(i1.ne.i) goto 10 + ts=t1-.05*rn + qs=(tt(i)+(tt(i)-tt(i+1))*rn)/pp + goto 20 +! 1 print *,'crash in surface energy budget - stop' + 1 print *,' avost in vilka table index= ',i +! print *,tn,d1,d2,pp,nstep,i,tt(i),ii,j,iland,isoil + print *,'i,j=',ii,j,'lu_index = ',iland, 'psfc[hpa] = ',pp, 'tsfc = ',tn + call wrf_error_fatal (' crash in surface energy budget ' ) + 20 continue !----------------------------------------------------------------------- - END SUBROUTINE VILKA + end subroutine vilka !----------------------------------------------------------------------- - SUBROUTINE SOILVEGIN ( mosaic_lu,mosaic_soil,soilfrac,nscat, & + subroutine soilvegin ( mosaic_lu,mosaic_soil,soilfrac,nscat, & shdmin, shdmax, & - NLCAT,IVGTYP,ISLTYP,iswater, & - IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,RDLAI2D,& - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J) + nlcat,ivgtyp,isltyp,iswater,myj, & + iforest,lufrac,vegfrac,emiss,pc,znt,lai,rdlai2d,& + qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j) !************************************************************************ -! Set-up soil and vegetation Parameters in the case when +! set-up soil and vegetation parameters in the case when ! snow disappears during the forecast and snow parameters ! shold be replaced by surface parameters according to ! soil and vegetation types in this point. ! -! Output: +! output: ! ! -! Soil parameters: -! DQM: MAX soil moisture content - MIN (m^3/m^3) -! REF: Reference soil moisture (m^3/m^3) -! WILT: Wilting PT soil moisture contents (m^3/m^3) -! QMIN: Air dry soil moist content limits (m^3/m^3) -! PSIS: SAT soil potential coefs. (m) -! KSAT: SAT soil diffusivity/conductivity coefs. (m/s) -! BCLH: Soil diffusivity/conductivity exponent. +! soil parameters: +! dqm: max soil moisture content - min (m^3/m^3) +! ref: reference soil moisture (m^3/m^3) +! wilt: wilting pt soil moisture contents (m^3/m^3) +! qmin: air dry soil moist content limits (m^3/m^3) +! psis: sat soil potential coefs. (m) +! ksat: sat soil diffusivity/conductivity coefs. (m/s) +! bclh: soil diffusivity/conductivity exponent. ! ! ************************************************************************ - IMPLICIT NONE + implicit none !--------------------------------------------------------------------------- integer, parameter :: nsoilclas=19 integer, parameter :: nvegclas=24+3 integer, parameter :: ilsnow=99 - INTEGER, INTENT(IN ) :: nlcat, nscat, iswater, i, j + integer, intent(in ) :: nlcat, nscat, iswater, i, j -!--- soiltyp classification according to STATSGO(nclasses=16) +!--- soiltyp classification according to statsgo(nclasses=16) ! -! 1 SAND SAND -! 2 LOAMY SAND LOAMY SAND -! 3 SANDY LOAM SANDY LOAM -! 4 SILT LOAM SILTY LOAM -! 5 SILT SILTY LOAM -! 6 LOAM LOAM -! 7 SANDY CLAY LOAM SANDY CLAY LOAM -! 8 SILTY CLAY LOAM SILTY CLAY LOAM -! 9 CLAY LOAM CLAY LOAM -! 10 SANDY CLAY SANDY CLAY -! 11 SILTY CLAY SILTY CLAY -! 12 CLAY LIGHT CLAY -! 13 ORGANIC MATERIALS LOAM -! 14 WATER -! 15 BEDROCK -! Bedrock is reclassified as class 14 -! 16 OTHER (land-ice) -! 17 Playa -! 18 Lava -! 19 White Sand +! 1 sand sand +! 2 loamy sand loamy sand +! 3 sandy loam sandy loam +! 4 silt loam silty loam +! 5 silt silty loam +! 6 loam loam +! 7 sandy clay loam sandy clay loam +! 8 silty clay loam silty clay loam +! 9 clay loam clay loam +! 10 sandy clay sandy clay +! 11 silty clay silty clay +! 12 clay light clay +! 13 organic materials loam +! 14 water +! 15 bedrock +! bedrock is reclassified as class 14 +! 16 other (land-ice) +! 17 playa +! 18 lava +! 19 white sand ! !---------------------------------------------------------------------- - REAL LQMA(nsoilclas),LRHC(nsoilclas), & - LPSI(nsoilclas),LQMI(nsoilclas), & - LBCL(nsoilclas),LKAS(nsoilclas), & - LWIL(nsoilclas),LREF(nsoilclas), & - DATQTZ(nsoilclas) -!-- LQMA Rawls et al.[1982] -! DATA LQMA /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398, + real lqma(nsoilclas),lrhc(nsoilclas), & + lpsi(nsoilclas),lqmi(nsoilclas), & + lbcl(nsoilclas),lkas(nsoilclas), & + lwil(nsoilclas),lref(nsoilclas), & + datqtz(nsoilclas) +!-- lqma rawls et al.[1982] +! data lqma /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398, ! & 0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/ !--- -!-- Clapp, R. and G. Hornberger, 1978: Empirical equations for some soil -! hydraulic properties, Water Resour. Res., 14, 601-604. +!-- clapp, r. and g. hornberger, 1978: empirical equations for some soil +! hydraulic properties, water resour. res., 14, 601-604. -!-- Clapp et al. [1978] - DATA LQMA /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, & +!-- clapp et al. [1978] + data lqma /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, & 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0, & 0.20, 0.435, 0.468, 0.200, 0.339/ -!-- LREF Rawls et al.[1982] -! DATA LREF /0.091, 0.125, 0.207, 0.330, 0.360, 0.270, 0.255, +!-- lref rawls et al.[1982] +! data lref /0.091, 0.125, 0.207, 0.330, 0.360, 0.270, 0.255, ! & 0.366, 0.318, 0.339, 0.387, 0.396, 0.329, 1.0, 0.108, 0.283/ -!-- Clapp et al. [1978] - DATA LREF /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, & +!-- clapp et al. [1978] + data lref /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, & 0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1., & 0.1, 0.249, 0.454, 0.17, 0.236/ -!-- LWIL Rawls et al.[1982] -! DATA LWIL/0.033, 0.055, 0.095, 0.133, 0.133, 0.117, 0.148, +!-- lwil rawls et al.[1982] +! data lwil/0.033, 0.055, 0.095, 0.133, 0.133, 0.117, 0.148, ! & 0.208, 0.197, 0.239, 0.250, 0.272, 0.066, 0.0, 0.006, 0.029/ -!-- Clapp et al. [1978] - DATA LWIL/0.068, 0.075, 0.114, 0.179, 0.179, 0.155, 0.175, & +!-- clapp et al. [1978] + data lwil/0.068, 0.075, 0.114, 0.179, 0.179, 0.155, 0.175, & 0.218, 0.250, 0.219, 0.283, 0.286, 0.155, 0.0, & 0.006, 0.114, 0.030, 0.006, 0.01/ -! DATA LQMI/0.010, 0.028, 0.047, 0.084, 0.084, 0.066, 0.067, +! data lqmi/0.010, 0.028, 0.047, 0.084, 0.084, 0.066, 0.067, ! & 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.0, 0.006, 0.028/ -!-- Carsel and Parrish [1988] - DATA LQMI/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & +!-- carsel and parrish [1988] + data lqmi/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & 0.004, 0.065, 0.020, 0.004, 0.008/ -!-- LPSI Cosby et al[1984] -! DATA LPSI/0.060, 0.036, 0.141, 0.759, 0.759, 0.355, 0.135, +!-- lpsi cosby et al[1984] +! data lpsi/0.060, 0.036, 0.141, 0.759, 0.759, 0.355, 0.135, ! & 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/ ! & 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/ -!-- Clapp et al. [1978] - DATA LPSI/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, & +!-- clapp et al. [1978] + data lpsi/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, & 0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0, & 0.121, 0.218, 0.468, 0.069, 0.069/ -!-- LKAS Rawls et al.[1982] -! DATA LKAS/5.83E-5, 1.70E-5, 7.19E-6, 1.89E-6, 1.89E-6, -! & 3.67E-6, 1.19E-6, 4.17E-7, 6.39E-7, 3.33E-7, 2.50E-7, -! & 1.67E-7, 3.38E-6, 0.0, 1.41E-4, 1.41E-5/ +!-- lkas rawls et al.[1982] +! data lkas/5.83e-5, 1.70e-5, 7.19e-6, 1.89e-6, 1.89e-6, +! & 3.67e-6, 1.19e-6, 4.17e-7, 6.39e-7, 3.33e-7, 2.50e-7, +! & 1.67e-7, 3.38e-6, 0.0, 1.41e-4, 1.41e-5/ -!-- Clapp et al. [1978] - DATA LKAS/1.76E-4, 1.56E-4, 3.47E-5, 7.20E-6, 7.20E-6, & - 6.95E-6, 6.30E-6, 1.70E-6, 2.45E-6, 2.17E-6, & - 1.03E-6, 1.28E-6, 6.95E-6, 0.0, 1.41E-4, & - 3.47E-5, 1.28E-6, 1.41E-4, 1.76E-4/ +!-- clapp et al. [1978] + data lkas/1.76e-4, 1.56e-4, 3.47e-5, 7.20e-6, 7.20e-6, & + 6.95e-6, 6.30e-6, 1.70e-6, 2.45e-6, 2.17e-6, & + 1.03e-6, 1.28e-6, 6.95e-6, 0.0, 1.41e-4, & + 3.47e-5, 1.28e-6, 1.41e-4, 1.76e-4/ -!-- LBCL Cosby et al [1984] -! DATA LBCL/2.79, 4.26, 4.74, 5.33, 5.33, 5.25, 6.66, +!-- lbcl cosby et al [1984] +! data lbcl/2.79, 4.26, 4.74, 5.33, 5.33, 5.25, 6.66, ! & 8.72, 8.17, 10.73, 10.39, 11.55, 5.25, 0.0, 2.79, 4.26/ -!-- Clapp et al. [1978] - DATA LBCL/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, & +!-- clapp et al. [1978] + data lbcl/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, & 7.75, 8.52, 10.40, 10.40, 11.40, 5.39, 0.0, & 4.05, 4.90, 11.55, 2.79, 2.79/ - DATA LRHC /1.47,1.41,1.34,1.27,1.27,1.21,1.18,1.32,1.23, & + data lrhc /1.47,1.41,1.34,1.27,1.27,1.21,1.18,1.32,1.23, & 1.18,1.15,1.09,1.21,4.18,2.03,2.10,1.09,2.03,1.47/ - DATA DATQTZ/0.92,0.82,0.60,0.25,0.10,0.40,0.60,0.10,0.35, & + data datqtz/0.92,0.82,0.60,0.25,0.10,0.40,0.60,0.10,0.35, & 0.52,0.10,0.25,0.00,0.,0.60,0.0,0.25,0.60,0.92/ !-------------------------------------------------------------------------- ! -! USGS Vegetation Types +! usgs vegetation types ! -! 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 Fores -! 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 +! 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 fores +! 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 - -! MODIS vegetation categories from VEGPARM.TBL -! 1: Evergreen Needleleaf Forest -! 2: Evergreen Broadleaf Forest -! 3: Deciduous Needleleaf Forest -! 4: Deciduous Broadleaf Forest -! 5: Mixed Forests -! 6: Closed Shrublands -! 7: Open Shrublands -! 8: Woody Savannas -! 9: Savannas -! 10: Grasslands -! 11: Permanent wetlands -! 12: Croplands -! 13: Urban and Built-Up +! 25: playa +! 26: lava +! 27: white sand + +! modis vegetation categories from VEGPARM.TBL +! 1: evergreen needleleaf forest +! 2: evergreen broadleaf forest +! 3: deciduous needleleaf forest +! 4: deciduous broadleaf forest +! 5: mixed forests +! 6: closed shrublands +! 7: open shrublands +! 8: woody savannas +! 9: savannas +! 10: grasslands +! 11: permanent wetlands +! 12: croplands +! 13: urban and built-up ! 14: cropland/natural vegetation mosaic -! 15: Snow and Ice -! 16: Barren or Sparsely Vegetated -! 17: Water -! 18: Wooded Tundra -! 19: Mixed Tundra -! 20: Barren Tundra -! 21: Lakes +! 15: snow and ice +! 16: barren or sparsely vegetated +! 17: water +! 18: wooded tundra +! 19: mixed tundra +! 20: barren tundra +! 21: lakes -!---- Below are the arrays for the vegetation parameters - REAL LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & - LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & - LPC(nvegclas) +!---- below are the arrays for the vegetation parameters + real lalb(nvegclas),lmoi(nvegclas),lemi(nvegclas), & + lrou(nvegclas),lthi(nvegclas),lsig(nvegclas), & + lpc(nvegclas) !************************************************************************ !---- vegetation parameters ! -!-- USGS model +!-- usgs model ! - DATA LALB/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, & + data lalb/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, & .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55, & .30,.16,.60 / - DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, & + data lemi/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, & .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, & .85,.85,.90 / -!-- Roughness length is changed for forests and some others -! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & +!-- roughness length is changed for forests and some others +! data lrou/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & ! 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ - DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & + data lrou/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, & .01,.15,.01 / - DATA LMOI/.1,.3,.5,.25,.25,.35,.15,.1,.15,.15,.3,.3, & + data lmoi/.1,.3,.5,.25,.25,.35,.15,.1,.15,.15,.3,.3, & .5,.3,.3,1.,.6,.35,.02,.5,.5,.5,.02,.95,.40,.50,.40/ ! !---- still needs to be corrected ! -! DATA LPC/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/ - DATA LPC /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55, & +! data lpc/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/ + data lpc /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55, & 0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./ -! used in RUC DATA LPC /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & +! used in ruc data lpc /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & ! 0.5,0.7,0.6,0.7,0.5,0./ !*************************************************************************** - INTEGER :: & - IVGTYP, & - ISLTYP - INTEGER, INTENT(IN ) :: mosaic_lu, mosaic_soil + integer :: & + ivgtyp, & + isltyp + integer, intent(in ) :: mosaic_lu, mosaic_soil - REAL, INTENT(IN ) :: SHDMAX - REAL, INTENT(IN ) :: SHDMIN - REAL, INTENT(IN ) :: VEGFRAC - REAL, DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC - REAL, DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC + logical, intent(in ) :: myj + real, intent(in ) :: shdmax + real, intent(in ) :: shdmin + real, intent(in ) :: vegfrac + real, dimension( 1:nlcat ), intent(in):: lufrac + real, dimension( 1:nscat ), intent(in):: soilfrac - REAL , & - INTENT ( OUT) :: pc + real , & + intent ( out) :: pc - REAL , & - INTENT (INOUT ) :: emiss, & + real , & + intent (inout ) :: emiss, & lai, & znt - LOGICAL, intent(in) :: rdlai2d + logical, intent(in) :: rdlai2d !--- soil properties - REAL , & - INTENT( OUT) :: RHOCS, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QMIN, & - QWRTZ, & - REF, & - WILT - INTEGER, INTENT ( OUT) :: iforest - -! INTEGER, DIMENSION( 1:(lucats) ) , & -! INTENT ( OUT) :: iforest - - -! INTEGER, DIMENSION( 1:50 ) :: if1 - INTEGER :: kstart, kfin, lstart, lfin - INTEGER :: k - REAL :: area, factor, znt1, lb - REAL, DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai + real , & + intent( out) :: rhocs, & + bclh, & + dqm, & + ksat, & + psis, & + qmin, & + qwrtz, & + ref, & + wilt + integer, intent ( out) :: iforest + +! integer, dimension( 1:(lucats) ) , & +! intent ( out) :: iforest + + +! integer, dimension( 1:50 ) :: if1 + integer :: kstart, kfin, lstart, lfin + integer :: k + real :: area, factor, znt1, lb + real, dimension( 1:nlcat ) :: znttoday, laitoday, deltalai !*********************************************************************** -! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil -! DATA ZS2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil +! data zs1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil +! data zs2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil -! DATA IF1/12*0,1,1,1,12*0/ +! data if1/12*0,1,1,1,12*0/ -! do k=1,LUCATS +! do k=1,lucats ! iforest(k)=if1(k) ! enddo - iforest = IFORTBL(IVGTYP) + iforest = ifortbl(ivgtyp) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then if(i.eq.375.and.j.eq.254)then print *,'ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)', & ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp) endif - ENDIF + endif deltalai(:) = 0. -! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types +! 11oct2012 - seasonal correction on znt for crops and lai for all veg. types ! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season) ! factor = 0 with maximum greenness --> vegfrac = shdmax -! SHDMAX, SHDMIN and VEGFRAC are in % here. +! shdmax, shdmin and vegfrac are in % here. if((shdmax - shdmin) .lt. 1) then factor = 1. ! min greenness else factor = 1. - max(0.,min(1.,(vegfrac - shdmin)/max(1.,(shdmax-shdmin)))) endif -! 18sept18 - LAITBL and Z0TBL are the max values +! 18sept18 - laitbl and z0tbl are the max values do k = 1,nlcat - if(IFORTBL(k) == 1) deltalai(k)=min(0.2,0.8*LAITBL(K)) - if(IFORTBL(k) == 2 .or. IFORTBL(k) == 7) deltalai(k)=min(0.5,0.8*LAITBL(K)) - if(IFORTBL(k) == 3) deltalai(k)=min(0.45,0.8*LAITBL(K)) - if(IFORTBL(k) == 4) deltalai(k)=min(0.75,0.8*LAITBL(K)) - if(IFORTBL(k) == 5) deltalai(k)=min(0.86,0.8*LAITBL(K)) + if(ifortbl(k) == 1) deltalai(k)=min(0.2,0.8*laitbl(k)) + if(ifortbl(k) == 2 .or. ifortbl(k) == 7) deltalai(k)=min(0.5,0.8*laitbl(k)) + if(ifortbl(k) == 3) deltalai(k)=min(0.45,0.8*laitbl(k)) + if(ifortbl(k) == 4) deltalai(k)=min(0.75,0.8*laitbl(k)) + if(ifortbl(k) == 5) deltalai(k)=min(0.86,0.8*laitbl(k)) if(k.ne.iswater) then -!-- 20aug18 - change in LAItoday based on the greenness fraction for the current day - LAItoday(k) = LAITBL(K) - deltalai(k) * factor +!-- 20aug18 - change in laitoday based on the greenness fraction for the current day + laitoday(k) = laitbl(k) - deltalai(k) * factor - if(IFORTBL(k) == 7) then -!-- seasonal change of roughness length for crops - ZNTtoday(k) = Z0TBL(K) - 0.125 * factor + if(ifortbl(k) == 7) then +!-- seasonal change of roughness length for crops + znttoday(k) = z0tbl(k) - 0.125 * factor else - ZNTtoday(k) = Z0TBL(K) + znttoday(k) = z0tbl(k) endif else - LAItoday(k) = LAITBL(K) -! ZNTtoday(k) = Z0TBL(K) - ZNTtoday(k) = ZNT ! do not overwrite z0 over water with the table value + laitoday(k) = laitbl(k) + znttoday(k) = znt ! do not overwrite z0 over water with the table value endif enddo - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then if(i.eq.358.and.j.eq.260)then print *,'ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp)', & i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp) endif - ENDIF + endif - EMISS = 0. - ZNT = 0. - ZNT1 = 0. - PC = 0. - if(.not.rdlai2d) LAI = 0. - AREA = 0. + emiss = 0. + znt = 0. + znt1 = 0. + pc = 0. + if(.not.rdlai2d) lai = 0. + area = 0. !-- mosaic approach to landuse in the grid box -! Use Mason (1988) Eq.(15) to compute effective ZNT; -! Lb - blending height = L/200., where L is the length scale -! of regions with varying Z0 (Lb = 5 if L=1000 m) - LB = 5. +! use mason (1988) eq.(15) to compute effective znt; +! lb - blending height = l/200., where l is the length scale of regions with varying z0 (lb = 5 if l=1000 m) + lb = 5. if(mosaic_lu == 1) then do k = 1,nlcat - AREA = AREA + lufrac(k) - EMISS = EMISS+ LEMITBL(K)*lufrac(k) - ZNT = ZNT + lufrac(k)/ALOG(LB/ZNTtoday(K))**2. -! ZNT1 - weighted average in the grid box, not used, computed for comparison - ZNT1 = ZNT1 + lufrac(k)*ZNTtoday(K) - if(.not.rdlai2d) LAI = LAI + LAItoday(K)*lufrac(k) - PC = PC + PCTBL(K)*lufrac(k) + area = area + lufrac(k) + emiss = emiss+ lemitbl(k)*lufrac(k) + znt = znt + lufrac(k)/alog(lb/znttoday(k))**2. +! znt1 - weighted average in the grid box, not used, computed for comparison + znt1 = znt1 + lufrac(k)*znttoday(k) + if(.not.rdlai2d) lai = lai + laitoday(k)*lufrac(k) + pc = pc + pctbl(k)*lufrac(k) enddo if (area.gt.1.) area=1. if (area <= 0.) then - print *,'Bad area of grid box', area + print *,'bad area of grid box', area stop endif - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then if(i.eq.358.and.j.eq.260) then - print *,'area=',area,i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),EMISS,ZNT,ZNT1,LAI,PC + print *,'area=',area,i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),emiss,znt,znt1,lai,pc endif - ENDIF + endif - EMISS = EMISS/AREA - ZNT1 = ZNT1/AREA - ZNT = LB/EXP(SQRT(1./ZNT)) - if(.not.rdlai2d) LAI = LAI/AREA - PC = PC /AREA + emiss = emiss/area + znt1 = znt1/area + znt = lb/exp(sqrt(1./znt)) + if(.not.rdlai2d) lai = lai/area + pc = pc /area - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if ( wrf_at_debug_level(lsmruc_dbg_lvl) ) then if(i.eq.358.and.j.eq.260) then - print *,'mosaic=',i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),EMISS,ZNT,ZNT1,LAI,PC + print *,'mosaic=',i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),emiss,znt,znt1,lai,pc endif - ENDIF + endif else - EMISS = LEMITBL(IVGTYP) - ZNT = ZNTtoday(IVGTYP) - PC = PCTBL(IVGTYP) - if(.not.rdlai2d) LAI = LAItoday(IVGTYP) + emiss = lemitbl(ivgtyp) + znt = znttoday(ivgtyp) + pc = pctbl(ivgtyp) + if(.not.rdlai2d) lai = laitoday(ivgtyp) endif -! parameters from SOILPARM.TBL - RHOCS = 0. - BCLH = 0. - DQM = 0. - KSAT = 0. - PSIS = 0. - QMIN = 0. - REF = 0. - WILT = 0. - QWRTZ = 0. - AREA = 0. +! parameters from soilparm.tbl + rhocs = 0. + bclh = 0. + dqm = 0. + ksat = 0. + psis = 0. + qmin = 0. + ref = 0. + wilt = 0. + qwrtz = 0. + area = 0. ! mosaic approach if(mosaic_soil == 1 ) then do k = 1, nscat - if(k.ne.14) then + if(k.ne.14) then ! statsgo value for water !exclude watrer points from this loop - AREA = AREA + soilfrac(k) - RHOCS = RHOCS + HC(k)*1.E6*soilfrac(k) - BCLH = BCLH + BB(K)*soilfrac(k) - DQM = DQM + (MAXSMC(K)- & - DRYSMC(K))*soilfrac(k) - KSAT = KSAT + SATDK(K)*soilfrac(k) - PSIS = PSIS - SATPSI(K)*soilfrac(k) - QMIN = QMIN + DRYSMC(K)*soilfrac(k) - REF = REF + REFSMC(K)*soilfrac(k) - WILT = WILT + WLTSMC(K)*soilfrac(k) - QWRTZ = QWRTZ + QTZ(K)*soilfrac(k) + area = area + soilfrac(k) + rhocs = rhocs + hc(k)*1.e6*soilfrac(k) + bclh = bclh + bb(k)*soilfrac(k) + dqm = dqm + (maxsmc(k)- & + drysmc(k))*soilfrac(k) + ksat = ksat + satdk(k)*soilfrac(k) + psis = psis - satpsi(k)*soilfrac(k) + qmin = qmin + drysmc(k)*soilfrac(k) + ref = ref + refsmc(k)*soilfrac(k) + wilt = wilt + wltsmc(k)*soilfrac(k) + qwrtz = qwrtz + qtz(k)*soilfrac(k) endif enddo if (area.gt.1.) area=1. if (area <= 0.) then ! area = 0. for water points -! print *,'Area of a grid box', area, 'iswater = ',iswater - RHOCS = HC(ISLTYP)*1.E6 - BCLH = BB(ISLTYP) - DQM = MAXSMC(ISLTYP)- & - DRYSMC(ISLTYP) - KSAT = SATDK(ISLTYP) - PSIS = - SATPSI(ISLTYP) - QMIN = DRYSMC(ISLTYP) - REF = REFSMC(ISLTYP) - WILT = WLTSMC(ISLTYP) - QWRTZ = QTZ(ISLTYP) +! print *,'area of a grid box', area, 'iswater = ',iswater + rhocs = hc(isltyp)*1.e6 + bclh = bb(isltyp) + dqm = maxsmc(isltyp)- & + drysmc(isltyp) + ksat = satdk(isltyp) + psis = - satpsi(isltyp) + qmin = drysmc(isltyp) + ref = refsmc(isltyp) + wilt = wltsmc(isltyp) + qwrtz = qtz(isltyp) else - RHOCS = RHOCS/AREA - BCLH = BCLH/AREA - DQM = DQM/AREA - KSAT = KSAT/AREA - PSIS = PSIS/AREA - QMIN = QMIN/AREA - REF = REF/AREA - WILT = WILT/AREA - QWRTZ = QWRTZ/AREA + rhocs = rhocs/area + bclh = bclh/area + dqm = dqm/area + ksat = ksat/area + psis = psis/area + qmin = qmin/area + ref = ref/area + wilt = wilt/area + qwrtz = qwrtz/area endif ! dominant category approach else if(isltyp.ne.14) then - RHOCS = HC(ISLTYP)*1.E6 - BCLH = BB(ISLTYP) - DQM = MAXSMC(ISLTYP)- & - DRYSMC(ISLTYP) - KSAT = SATDK(ISLTYP) - PSIS = - SATPSI(ISLTYP) - QMIN = DRYSMC(ISLTYP) - REF = REFSMC(ISLTYP) - WILT = WLTSMC(ISLTYP) - QWRTZ = QTZ(ISLTYP) - endif + rhocs = hc(isltyp)*1.e6 + bclh = bb(isltyp) + dqm = maxsmc(isltyp)- & + drysmc(isltyp) + ksat = satdk(isltyp) + psis = - satpsi(isltyp) + qmin = drysmc(isltyp) + ref = refsmc(isltyp) + wilt = wltsmc(isltyp) + qwrtz = qtz(isltyp) + endif endif - -! parameters from the look-up tables -! BCLH = LBCL(ISLTYP) -! DQM = LQMA(ISLTYP)- & -! LQMI(ISLTYP) -! KSAT = LKAS(ISLTYP) -! PSIS = - LPSI(ISLTYP) -! QMIN = LQMI(ISLTYP) -! REF = LREF(ISLTYP) -! WILT = LWIL(ISLTYP) -! QWRTZ = DATQTZ(ISLTYP) !-------------------------------------------------------------------------- - END SUBROUTINE SOILVEGIN + end subroutine soilvegin !-------------------------------------------------------------------------- - SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP, & - mminlu, XICE,mavail,nzs, iswater, isice, & + subroutine ruclsminit( sh2o,smfr3d,tslb,smois,isltyp,ivgtyp, & + mminlu, xice,mavail,nzs, iswater, isice, & znt, restart, allowed_to_read , & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) -#if ( WRF_CHEM == 1 ) - USE module_data_gocart_dust +#if ( wrf_chem == 1 ) + use module_data_gocart_dust #endif - IMPLICIT NONE + implicit none - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs, iswater, isice - CHARACTER(LEN=*), INTENT(IN ) :: MMINLU + character(len=*), intent(in ) :: mminlu - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(IN) :: TSLB, & - SMOIS + real, dimension( ims:ime, 1:nzs, jms:jme ) , & + intent(in) :: tslb, & + smois - INTEGER, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ISLTYP,IVGTYP + integer, dimension( ims:ime, jms:jme ) , & + intent(inout) :: isltyp,ivgtyp - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(INOUT) :: SMFR3D, & - SH2O + real, dimension( ims:ime, 1:nzs, jms:jme ) , & + intent(inout) :: smfr3d, & + sh2o - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: XICE,MAVAIL + real, dimension( ims:ime, jms:jme ) , & + intent(inout) :: xice,mavail - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT( OUT) :: znt + real, dimension( ims:ime, jms:jme ) , & + intent( out) :: znt - REAL, DIMENSION ( 1:nzs ) :: SOILIQW + real, dimension ( 1:nzs ) :: soiliqw - LOGICAL , INTENT(IN) :: restart, allowed_to_read + logical , intent(in) :: restart, allowed_to_read ! - INTEGER :: I,J,L,itf,jtf - REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH - - character*8 :: MMINLURUC, MMINSL + integer :: i,j,l,itf,jtf + real :: riw,xlmelt,tln,dqm,ref,psis,qmin,bclh - INTEGER :: errflag + character*8 :: mminluruc, mminsl -! itf=min0(ite,ide-1) -! jtf=min0(jte,jde-1) + integer :: errflag + riw=900.*1.e-3 + xlmelt=3.35e+5 - RIW=900.*1.e-3 - XLMELT=3.35E+5 - -! initialize three LSM related tables - IF ( allowed_to_read ) THEN - CALL wrf_message( 'INITIALIZE THREE LSM RELATED TABLES' ) +! initialize three lsm related tables + if ( allowed_to_read ) then + call wrf_message( 'initialize three lsm related tables' ) if(mminlu == 'USGS') then - MMINLURUC='USGS-RUC' - elseif(mminlu == 'MODIS' .OR. & + mminluruc='USGS-RUC' + elseif(mminlu == 'MODIS' .or. & & mminlu == 'MODIFIED_IGBP_MODIS_NOAH') then - MMINLURUC='MODI-RUC' + mminluruc='MODI-RUC' endif - MMINSL='STAS-RUC' -! CALL RUCLSM_PARM_INIT - print *,'RUCLSMINIT uses ',mminluruc - call RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) - ENDIF + mminsl='STAS-RUC' + print *,'ruclsminit uses ',mminluruc + call ruclsm_soilvegparm( mminluruc, mminsl) + endif -!#if ( WRF_CHEM == 1 ) +!#if ( wrf_chem == 1 ) ! ! need this parameter for dust parameterization in wrf/chem ! -! do I=1,NSLTYPE +! do i=1,nsltype ! porosity(i)=maxsmc(i) ! drypoint(i)=drysmc(i) ! enddo !#endif ! - IF(.not.restart)THEN + if(.not.restart)then itf=min0(ite,ide-1) jtf=min0(jte,jde-1) errflag = 0 - DO j = jts,jtf - DO i = its,itf - IF ( ISLTYP( i,j ) .LT. 1 ) THEN + do j = jts,jtf + do i = its,itf + if ( isltyp( i,j ) .lt. 1 ) then errflag = 1 - WRITE(err_message,*)"module_sf_ruclsm.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) - CALL wrf_message(err_message) - ENDIF - ENDDO - ENDDO - IF ( errflag .EQ. 1 ) THEN - CALL wrf_error_fatal( "module_sf_ruclsm.F: lsminit: out of range value "// & - "of ISLTYP. Is this field in the input?" ) - ENDIF - - DO J=jts,jtf - DO I=its,itf - - ZNT(I,J) = Z0TBL(IVGTYP(I,J)) - -! CALL SOILIN ( ISLTYP(I,J), DQM, REF, PSIS, QMIN, BCLH ) + write(err_message,*)"module_sf_ruclsm.f: lsminit: out of range isltyp ",i,j,isltyp( i,j ) + call wrf_message(err_message) + endif + enddo + enddo + if ( errflag .eq. 1 ) then + call wrf_error_fatal( "module_sf_ruclsm.f: lsminit: out of range value "// & + "of isltyp. is this field in the input?" ) + endif + do j=jts,jtf + do i=its,itf -!--- Computation of volumetric content of ice in soil -!--- and initialize MAVAIL - DQM = MAXSMC (ISLTYP(I,J)) - & - DRYSMC (ISLTYP(I,J)) - REF = REFSMC (ISLTYP(I,J)) - PSIS = - SATPSI (ISLTYP(I,J)) - QMIN = DRYSMC (ISLTYP(I,J)) - BCLH = BB (ISLTYP(I,J)) + znt(i,j) = z0tbl(ivgtyp(i,j)) +!--- computation of volumetric content of ice in soil +!--- and initialize mavail + dqm = maxsmc (isltyp(i,j)) - & + drysmc (isltyp(i,j)) + ref = refsmc (isltyp(i,j)) + psis = - satpsi (isltyp(i,j)) + qmin = drysmc (isltyp(i,j)) + bclh = bb (isltyp(i,j)) -!!! IF (.not.restart) THEN - IF(xice(i,j).gt.0.) THEN + if(xice(i,j).gt.0.) then !-- for ice - DO L=1,NZS + do l=1,nzs smfr3d(i,l,j)=1. sh2o(i,l,j)=0. mavail(i,j) = 1. - ENDDO - ELSE + enddo + else if(isltyp(i,j).ne.14 ) then !-- land mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) - DO L=1,NZS + do l=1,nzs !-- for land points initialize soil ice - tln=log(TSLB(i,l,j)/273.15) + tln=log(tslb(i,l,j)/273.15) if(tln.lt.0.) then - soiliqw(l)=(dqm+qmin)*(XLMELT* & + soiliqw(l)=(dqm+qmin)*(xlmelt* & (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & **(-1./bclh) -! **(-1./bclh)-qmin soiliqw(l)=max(0.,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) sh2o(i,l,j)=soiliqw(l) - smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW + smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/riw else smfr3d(i,l,j)=0. sh2o(i,l,j)=smois(i,l,j) endif - ENDDO + enddo else -!-- for water ISLTYP=14 - DO L=1,NZS +!-- for water isltyp=14 + do l=1,nzs smfr3d(i,l,j)=0. sh2o(i,l,j)=1. mavail(i,j) = 1. - ENDDO + enddo endif - ENDIF - - ENDDO - ENDDO - - ENDIF - - END SUBROUTINE ruclsminit -! -!----------------------------------------------------------------- -! SUBROUTINE RUCLSM_PARM_INIT -!----------------------------------------------------------------- + endif -! character*9 :: MMINLU, MMINSL + enddo + enddo -! MMINLU='MODIS-RUC' -! MMINLU='USGS-RUC' -! MMINSL='STAS-RUC' -! call RUCLSM_SOILVEGPARM( MMINLU, MMINSL) + endif !----------------------------------------------------------------- -! END SUBROUTINE RUCLSM_PARM_INIT + end subroutine ruclsminit !----------------------------------------------------------------- - -!----------------------------------------------------------------- - SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) +! + subroutine ruclsm_soilvegparm( mminluruc, mminsl) !----------------------------------------------------------------- - IMPLICIT NONE + implicit none integer :: LUMATCH, IINDEX, LC, NUM_SLOPE integer :: ierr @@ -7158,30 +7160,30 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) logical, external :: wrf_dm_on_monitor -!-----SPECIFY VEGETATION RELATED CHARACTERISTICS : -! ALBBCK: SFC albedo (in percentage) -! Z0: Roughness length (m) -! LEMI: Emissivity -! PC: Plant coefficient for transpiration function +!-----specify vegetation related characteristics : +! albbck: sfc albedo (in percentage) +! z0: roughness length (m) +! lemi: emissivity +! pc: plant coefficient for transpiration function ! -- the rest of the parameters are read in but not used currently -! SHDFAC: Green vegetation fraction (in percentage) -! Note: The ALBEDO, Z0, and SHDFAC values read from the following table -! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is +! shdfac: green vegetation fraction (in percentage) +! note: the albedo, z0, and shdfac values read from the following table +! albedo, amd z0 are specified in land-use table; and shdfac is ! the monthly green vegetation data -! CMXTBL: MAX CNPY Capacity (m) -! RSMIN: Mimimum stomatal resistance (s m-1) -! RSMAX: Max. stomatal resistance (s m-1) -! RGL: Parameters used in radiation stress function -! HS: Parameter used in vapor pressure deficit functio -! TOPT: Optimum transpiration air temperature. (K) -! CMCMAX: Maximum canopy water capacity -! CFACTR: Parameter used in the canopy inteception calculati -! SNUP: Threshold snow depth (in water equivalent m) that +! cmxtbl: max cnpy capacity (m) +! rsmin: mimimum stomatal resistance (s m-1) +! rsmax: max. stomatal resistance (s m-1) +! rgl: parameters used in radiation stress function +! hs: parameter used in vapor pressure deficit functio +! topt: optimum transpiration air temperature. (k) +! cmcmax: maximum canopy water capacity +! cfactr: parameter used in the canopy inteception calculati +! snup: threshold snow depth (in water equivalent m) that ! implies 100% snow cover -! LAI: Leaf area index (dimensionless) -! MAXALB: Upper bound on maximum albedo over deep snow +! lai: leaf area index (dimensionless) +! maxalb: upper bound on maximum albedo over deep snow ! -!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL +!-----read in vegetaion properties from VEGPARM.TBL ! IF ( wrf_dm_on_monitor() ) THEN @@ -7200,7 +7202,7 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) 2000 FORMAT (A8) READ (19,'(A)') vege_parm_string - outer : DO + outer : DO READ (19,2000,END=2002)LUTYPE READ (19,*)LUCATS,IINDEX @@ -7263,11 +7265,10 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) 2002 CONTINUE CLOSE (19) !----- - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + IF ( wrf_at_debug_level(lsmruc_dbg_lvl) ) THEN print *,' LEMITBL, PCTBL, Z0TBL, LAITBL --->', LEMITBL, PCTBL, Z0TBL, LAITBL ENDIF - IF (LUMATCH == 0) then CALL wrf_error_fatal ("Land Use Dataset '"//MMINLURUC//"' not found in VEGPARM.TBL.") ENDIF @@ -7299,9 +7300,9 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) CALL wrf_dm_bcast_integer ( CROP , 1 ) CALL wrf_dm_bcast_integer ( URBAN , 1 ) -! +! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL -! +! IF ( wrf_dm_on_monitor() ) THEN OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN @@ -7328,7 +7329,7 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) READ (19,*) READ (19,2000,END=2003)SLTYPE READ (19,*)SLCATS,IINDEX - + IF(SLTYPE.EQ.MMINSL)THEN WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ',SLTYPE,' FOUND', & SLCATS,' CATEGORIES' @@ -7369,10 +7370,9 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) CALL wrf_message( 'MATCH SOILPARM TABLE' ) CALL wrf_error_fatal ( 'INCONSISTENT OR MISSING SOILPARM FILE' ) ENDIF - ! -!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL -! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! IF ( wrf_dm_on_monitor() ) THEN OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN @@ -7433,35 +7433,35 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) !----------------------------------------------------------------- - END SUBROUTINE RUCLSM_SOILVEGPARM + end subroutine ruclsm_soilvegparm !----------------------------------------------------------------- - SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) + subroutine soilin (isltyp, dqm, ref, psis, qmin, bclh ) -!--- soiltyp classification according to STATSGO(nclasses=16) +!--- soiltyp classification according to statsgo(nclasses=16) ! -! 1 SAND SAND -! 2 LOAMY SAND LOAMY SAND -! 3 SANDY LOAM SANDY LOAM -! 4 SILT LOAM SILTY LOAM -! 5 SILT SILTY LOAM -! 6 LOAM LOAM -! 7 SANDY CLAY LOAM SANDY CLAY LOAM -! 8 SILTY CLAY LOAM SILTY CLAY LOAM -! 9 CLAY LOAM CLAY LOAM -! 10 SANDY CLAY SANDY CLAY -! 11 SILTY CLAY SILTY CLAY -! 12 CLAY LIGHT CLAY -! 13 ORGANIC MATERIALS LOAM -! 14 WATER -! 15 BEDROCK -! Bedrock is reclassified as class 14 -! 16 OTHER (land-ice) -! extra classes from Fei Chen -! 17 Playa -! 18 Lava -! 19 White Sand +! 1 sand sand +! 2 loamy sand loamy sand +! 3 sandy loam sandy loam +! 4 silt loam silty loam +! 5 silt silty loam +! 6 loam loam +! 7 sandy clay loam sandy clay loam +! 8 silty clay loam silty clay loam +! 9 clay loam clay loam +! 10 sandy clay sandy clay +! 11 silty clay silty clay +! 12 clay light clay +! 13 organic materials loam +! 14 water +! 15 bedrock +! bedrock is reclassified as class 14 +! 16 other (land-ice) +! extra classes from fei chen +! 17 playa +! 18 lava +! 19 white sand ! !---------------------------------------------------------------------- integer, parameter :: nsoilclas=19 @@ -7469,48 +7469,48 @@ SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) integer, intent ( in) :: isltyp real, intent ( out) :: dqm,ref,qmin,psis - REAL LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & - LPSI(nsoilclas),LQMI(nsoilclas) + real lqma(nsoilclas),lref(nsoilclas),lbcl(nsoilclas), & + lpsi(nsoilclas),lqmi(nsoilclas) -!-- LQMA Rawls et al.[1982] -! DATA LQMA /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398, +!-- lqma rawls et al.[1982] +! data lqma /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398, ! & 0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/ !--- -!-- Clapp, R. and G. Hornberger, Empirical equations for some soil -! hydraulic properties, Water Resour. Res., 14,601-604,1978. -!-- Clapp et al. [1978] - DATA LQMA /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, & +!-- clapp, r. and g. hornberger, empirical equations for some soil +! hydraulic properties, water resour. res., 14,601-604,1978. +!-- clapp et al. [1978] + data lqma /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, & 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0, & 0.20, 0.435, 0.468, 0.200, 0.339/ -!-- Clapp et al. [1978] - DATA LREF /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, & +!-- clapp et al. [1978] + data lref /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, & 0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1., & 0.1, 0.249, 0.454, 0.17, 0.236/ -!-- Carsel and Parrish [1988] - DATA LQMI/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & +!-- carsel and parrish [1988] + data lqmi/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & 0.004, 0.065, 0.020, 0.004, 0.008/ -!-- Clapp et al. [1978] - DATA LPSI/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, & +!-- clapp et al. [1978] + data lpsi/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, & 0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0, & 0.121, 0.218, 0.468, 0.069, 0.069/ -!-- Clapp et al. [1978] - DATA LBCL/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, & +!-- clapp et al. [1978] + data lbcl/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, & 7.75, 8.52, 10.40, 10.40, 11.40, 5.39, 0.0, & 4.05, 4.90, 11.55, 2.79, 2.79/ - DQM = LQMA(ISLTYP)- & - LQMI(ISLTYP) - REF = LREF(ISLTYP) - PSIS = - LPSI(ISLTYP) - QMIN = LQMI(ISLTYP) - BCLH = LBCL(ISLTYP) + dqm = lqma(isltyp)- & + lqmi(isltyp) + ref = lref(isltyp) + psis = - lpsi(isltyp) + qmin = lqmi(isltyp) + bclh = lbcl(isltyp) - END SUBROUTINE SOILIN + end subroutine soilin -END MODULE module_sf_ruclsm +end module module_sf_ruclsm diff --git a/phys/module_sf_sfclay.F b/phys/module_sf_sfclay.F index 2b3ba578f0..03072e82a6 100644 --- a/phys/module_sf_sfclay.F +++ b/phys/module_sf_sfclay.F @@ -20,7 +20,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000mb, & + P1000mb,LAKEMASK, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -136,6 +136,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & @@ -242,7 +243,7 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & QSFC(ims,j),LH(ims,j), & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & - P1000mb, & + P1000mb,LAKEMASK(ims,j), & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -267,7 +268,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000mb, & + P1000mb,LAKEMASK, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -278,6 +279,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !------------------------------------------------------------------- REAL, PARAMETER :: XKA=2.4E-5 REAL, PARAMETER :: PRT=1. + REAL, PARAMETER :: SALINITY_FACTOR=0.98 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -294,6 +296,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK ! REAL, DIMENSION( ims:ime ) , & @@ -452,7 +455,9 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO 60 I=its,ite E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) ! for land points QSFC can come from previous time step - if(xland(i).gt.1.5.or.qsfc(i).le.0.0)QSFC(I)=EP2*E1/(PSFC(I)-E1) +! the saturation vapor pressure for salty water is on average 2% lower + if(xland(i).gt.1.5 .and. lakemask(i).eq.0.) E1=E1*SALINITY_FACTOR + if(xland(i).gt.1.5.or.qsfc(i).le.0.0)QSFC(I)=EP2*E1/(PSFC(I)-E1) ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE ! Q2SAT = QGH IN LSM E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) @@ -892,7 +897,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! DO 370 I=its,ite QFX(I)=FLQC(I)*(QSFC(I)-QX(I)) - QFX(I)=AMAX1(QFX(I),0.) +! QFX(I)=AMAX1(QFX(I),0.) LH(I)=XLV*QFX(I) 370 CONTINUE @@ -910,7 +915,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! ENDIF ELSEIF(XLAND(I)-1.5.LT.0.)THEN HFX(I)=FLHC(I)*(THGB(I)-THX(I)) - HFX(I)=AMAX1(HFX(I),-250.) +! HFX(I)=AMAX1(HFX(I),-250.) ENDIF 400 CONTINUE diff --git a/phys/module_sf_sfclayrev.F b/phys/module_sf_sfclayrev.F index 9f65730122..8f8939a8e1 100644 --- a/phys/module_sf_sfclayrev.F +++ b/phys/module_sf_sfclayrev.F @@ -1,1373 +1,319 @@ -!WRF:MODEL_LAYER:PHYSICS -! -MODULE module_sf_sfclayrev - - REAL , PARAMETER :: VCONVC=1. - REAL , PARAMETER :: CZO=0.0185 - REAL , PARAMETER :: OZO=1.59E-5 - - REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab,psih_stab,psih_unstab - -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,EOMEG,STBOLT, & - P1000mb, & - 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,shalwater_depth, & - scm_force_flux ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! Changes in V3.7 over water surfaces: -! 1. for ZNT/Cd, replacing constant OZO with 0.11*1.5E-5/UST(I) -! the COARE 3.5 (Edson et al. 2013) formulation is also available -! 2. for VCONV, reducing magnitude by half -! 3. for Ck, replacing Carlson-Boland with COARE 3 -!------------------------------------------------------------------- -!-- 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) -!-- dz8w 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) -!-- PSFC surface pressure (Pa) -!-- ZNT roughness length (m) -!-- UST u* in similarity theory (m/s) -!-- USTM u* in similarity theory (m/s) without vconv correction -! used to couple with TKE scheme -!-- 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) -!-- REGIME flag indicating PBL regime (stable, unstable, etc.) -!-- PSIM similarity stability function for momentum -!-- PSIH similarity stability function for heat -!-- FM integrated stability function for momentum -!-- FH integrated 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 ground saturated mixing ratio -!-- 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) -!-- GZ1OZ0 log(z/z0) where z0 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 (kPa) -!-- SVP2 constant for saturation vapor pressure (dimensionless) -!-- SVP3 constant for saturation vapor pressure (K) -!-- SVPT0 constant for saturation vapor pressure (K) -!-- EP1 constant for virtual temperature (R_v/R_d - 1) (dimensionless) -!-- EP2 constant for specific humidity calculation -! (R_d/R_v) (dimensionless) -!-- KARMAN Von Karman constant -!-- EOMEG angular velocity of earth's rotation (rad/s) -!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) -!-- 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, (Charnock and Carlson-Boland); =1, AHW Ck, Cd, =2 Garratt -!-- iz0tlnd =0 Carlson-Boland, =1 Czil_new -!-- 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 ) :: ISFFLX - REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT - REAL, INTENT(IN ) :: P1000mb -! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: dz8w - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: QV3D, & - P3D, & - T3D - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: MAVAIL, & - PBLH, & - XLAND, & - TSK - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT ) :: U10, & - V10, & - TH2, & - T2, & - Q2 - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: REGIME, & - HFX, & - QFX, & - LH, & - QSFC, & - MOL,RMOL -!m the following 5 are change to memory size -! - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & - PSIM,PSIH,FM,FH - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: U3D, & - V3D - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: PSFC - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ZNT, & - ZOL, & - UST, & - CPM, & - CHS2, & - CQS2, & - CHS - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: FLHC,FLQC - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: & - QGH - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX - - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda - - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: USTM - - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX - - INTEGER, INTENT(IN ) :: shalwater_z0 - REAL, INTENT(IN ) :: shalwater_depth - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: water_depth -! LOCAL VARS - - REAL, DIMENSION( its:ite ) :: U1D, & - V1D, & - QV1D, & - P1D, & - T1D - - REAL, DIMENSION( its:ite ) :: dz8w1d - - INTEGER :: I,J - - DO J=jts,jte - DO i=its,ite - dz8w1d(I) = dz8w(i,1,j) - ENDDO - - DO i=its,ite - U1D(i) =U3D(i,1,j) - V1D(i) =V3D(i,1,j) - QV1D(i)=QV3D(i,1,j) - P1D(i) =P3D(i,1,j) - T1D(i) =T3D(i,1,j) - ENDDO - - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - - CALL SFCLAYREV1D(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & - CP,G,ROVCP,R,XLV,PSFC(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), & - FM(ims,j),FH(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),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,EOMEG,STBOLT, & - P1000mb, & - shalwater_z0,water_depth(ims,j),shalwater_depth, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & -#if ( EM_CORE == 1 ) - ,isftcflx,iz0tlnd,scm_force_flux, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j) & +!================================================================================================================= + module module_sf_sfclayrev + use ccpp_kind_types,only: kind_phys + use sf_sfclayrev,only: sf_sfclayrev_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, & + its=its,ite=ite,errmsg=errmsg,errflg=errflg & +#if ( ( EM_CORE == 1 ) || ( defined(mpas) ) ) + ,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 & #endif - ) - ENDDO - - - END SUBROUTINE SFCLAYREV - - -!------------------------------------------------------------------- - SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & - CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,PBLH,RMOL, & - ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,FM,FH,& - XLAND,HFX,QFX,TSK, & - U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH, & - QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000mb, & - shalwater_z0,water_depth,shalwater_depth, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - isftcflx, iz0tlnd,scm_force_flux, & - ustm,ck,cka,cd,cda ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - REAL, PARAMETER :: XKA=2.4E-5 - REAL, PARAMETER :: PRT=1. - - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - J -! - INTEGER, INTENT(IN ) :: ISFFLX - REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT - REAL, INTENT(IN ) :: P1000mb - -! - REAL, DIMENSION( ims:ime ) , & - INTENT(IN ) :: MAVAIL, & - PBLH, & - XLAND, & - TSK -! - REAL, DIMENSION( ims:ime ) , & - INTENT(IN ) :: PSFCPA - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: REGIME, & - HFX, & - QFX, & - MOL,RMOL -!m the following 5 are changed to memory size--- -! - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & - PSIM,PSIH,FM,FH - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: ZNT, & - ZOL, & - UST, & - CPM, & - CHS2, & - CQS2, & - CHS - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: FLHC,FLQC - - REAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: & - QSFC,QGH - - REAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: U10,V10, & - TH2,T2,Q2,LH - - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX - - INTEGER, INTENT(IN ) :: shalwater_z0 - REAL, INTENT(IN ) :: shalwater_depth - REAL, DIMENSION( ims:ime ), INTENT(IN) :: water_depth -! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY - REAL, DIMENSION( its:ite ), INTENT(IN ) :: dz8w1d - - REAL, DIMENSION( its:ite ), INTENT(IN ) :: UX, & - VX, & - QV1D, & - P1D, & - T1D - - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: USTM - - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX - -! LOCAL VARS - - REAL, DIMENSION( its:ite ) :: ZA, & - THVX,ZQKL, & - ZQKLP1, & - THX,QX, & - PSIH2, & - PSIM2, & - PSIH10, & - PSIM10, & - DENOMQ, & - DENOMQ2, & - DENOMT2, & - WSPDI, & - GZ2OZ0, & - GZ10OZ0 -! - REAL, DIMENSION( its:ite ) :: & - RHOX,GOVRTH, & - TGDSA -! - REAL, DIMENSION( its:ite) :: SCR3,SCR4 - REAL, DIMENSION( its:ite ) :: THGB, PSFC -! - INTEGER :: KL - - INTEGER :: N,I,K,KK,L,NZOL,NK,NZOL2,NZOL10 - - REAL :: PL,THCON,TVCON,E1 - REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 - REAL :: DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10 - REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT - REAL :: ZW, ZN1, ZN2 -! -! .... paj ... -! - REAL :: zolzz,zol0 -! REAL :: zolri,zolri2 -! REAL :: psih_stable,psim_stable,psih_unstable,psim_unstable -! REAL :: psih_stable_full,psim_stable_full,psih_unstable_full,psim_unstable_full - REAL :: zl2,zl10,z0t - REAL, DIMENSION( its:ite ) :: pq,pq2,pq10 - - -!------------------------------------------------------------------- - KL=kte - - DO i=its,ite -! PSFC cb - PSFC(I)=PSFCPA(I)/1000. - ENDDO -! -!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: -! - DO 5 I=its,ite - TGDSA(I)=TSK(I) -! PSFC cb -! THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP - THGB(I)=TSK(I)*(P1000mb/PSFCPA(I))**ROVCP - 5 CONTINUE -! -!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., -! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. -! -! *** NOTE *** -! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, -! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE -! TENDENCIES. -! - 10 CONTINUE - -! DO 24 I=its,ite -! UX(I)=U1D(I) -! VX(I)=V1D(I) -! 24 CONTINUE - - 26 CONTINUE - -!.....SCR3(I,K) STORE TEMPERATURE, -! SCR4(I,K) STORE VIRTUAL TEMPERATURE. - - DO 30 I=its,ite -! PL cb - PL=P1D(I)/1000. - SCR3(I)=T1D(I) -! THCON=(100./PL)**ROVCP - THCON=(P1000mb*0.001/PL)**ROVCP - THX(I)=SCR3(I)*THCON - SCR4(I)=SCR3(I) - THVX(I)=THX(I) - QX(I)=0. - 30 CONTINUE -! - DO I=its,ite - QGH(I)=0. - FLHC(I)=0. - FLQC(I)=0. - CPM(I)=CP - ENDDO -! -! IF(IDRY.EQ.1)GOTO 80 - DO 50 I=its,ite - QX(I)=QV1D(I) - TVCON=(1.+EP1*QX(I)) - THVX(I)=THX(I)*TVCON - SCR4(I)=SCR3(I)*TVCON - 50 CONTINUE -! - DO 60 I=its,ite - E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) -! for land points QSFC can come from previous time step - if(xland(i).gt.1.5.or.qsfc(i).le.0.0)QSFC(I)=EP2*E1/(PSFC(I)-E1) -! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE -! Q2SAT = QGH IN LSM - E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) - PL=P1D(I)/1000. - QGH(I)=EP2*E1/(PL-E1) - CPM(I)=CP*(1.+0.8*QX(I)) - 60 CONTINUE - 80 CONTINUE - -!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND -! LEVEL, AND THE LAYER THICKNESSES. - - DO 90 I=its,ite - ZQKLP1(I)=0. - RHOX(I)=PSFC(I)*1000./(R*SCR4(I)) - 90 CONTINUE -! - DO 110 I=its,ite - ZQKL(I)=dz8w1d(I)+ZQKLP1(I) - 110 CONTINUE -! - DO 120 I=its,ite - ZA(I)=0.5*(ZQKL(I)+ZQKLP1(I)) - 120 CONTINUE -! - DO 160 I=its,ite - GOVRTH(I)=G/THX(I) - 160 CONTINUE - -!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO -! AKB(1976), EQ(12). - - DO 260 I=its,ite - GZ1OZ0(I)=ALOG((ZA(I)+ZNT(I))/ZNT(I)) ! log((z+z0)/z0) - GZ2OZ0(I)=ALOG((2.+ZNT(I))/ZNT(I)) ! log((2+z0)/z0) - GZ10OZ0(I)=ALOG((10.+ZNT(I))/ZNT(I)) ! log((10+z0)z0) - IF((XLAND(I)-1.5).GE.0)THEN - ZL=ZNT(I) - ELSE - ZL=0.01 - ENDIF - WSPD(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) - - TSKV=THGB(I)*(1.+EP1*QSFC(I)) - DTHVDZ=(THVX(I)-TSKV) -! Convective velocity scale Vc and subgrid-scale velocity Vsg -! following Beljaars (1994, QJRMS) and Mahrt and Sun (1995, MWR) -! ... HONG Aug. 2001 -! -! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm) -! Use Beljaars over land, old MM5 (Wyngaard) formula over water - if (xland(i).lt.1.5) then - fluxc = max(hfx(i)/rhox(i)/cp & - + ep1*tskv*qfx(i)/rhox(i),0.) - VCONV = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 - else - IF(-DTHVDZ.GE.0)THEN - DTHVM=-DTHVDZ - ELSE - DTHVM=0. - ENDIF -! VCONV = 2.*SQRT(DTHVM) -! V3.7: reducing contribution in calm conditions - VCONV = SQRT(DTHVM) - endif -! Mahrt and Sun low-res correction - VSGD = 0.32 * (max(dx/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)) -! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 - IF(MOL(I).LT.0.)BR(I)=AMIN1(BR(I),0.0) -!jdf - RMOL(I)=-GOVRTH(I)*DTHVDZ*ZA(I)*KARMAN -!jdf - - 260 CONTINUE - -! -!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: -! -! -! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) -! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). -! -! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: -! -! 1. BR .GE. 0.0; -! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), -! -! 3. BR .EQ. 0.0 -! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), -! -! 4. BR .LT. 0.0 -! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). -! -!CCCCC - - DO 320 I=its,ite -! - if (br(I).gt.0) then - if (br(I).gt.250.0) then - zol(I)=zolri(250.0,ZA(I),ZNT(I)) - else - zol(I)=zolri(br(I),ZA(I),ZNT(I)) - endif - endif -! - if (br(I).lt.0) then - IF(UST(I).LT.0.001)THEN - ZOL(I)=BR(I)*GZ1OZ0(I) - ELSE - if (br(I).lt.-250.0) then - zol(I)=zolri(-250.0,ZA(I),ZNT(I)) - else - zol(I)=zolri(br(I),ZA(I),ZNT(I)) - endif - ENDIF - endif -! -! ... paj: compute integrated similarity functions. -! - zolzz=zol(I)*(za(I)+znt(I))/za(I) ! (z+z0/L - zol10=zol(I)*(10.+znt(I))/za(I) ! (10+z0)/L - zol2=zol(I)*(2.+znt(I))/za(I) ! (2+z0)/L - zol0=zol(I)*znt(I)/za(I) ! z0/L - ZL2=(2.)/ZA(I)*ZOL(I) ! 2/L - ZL10=(10.)/ZA(I)*ZOL(I) ! 10/L - - IF((XLAND(I)-1.5).LT.0.)THEN - ZL=(0.01)/ZA(I)*ZOL(I) ! (0.01)/L - ELSE - ZL=ZOL0 ! z0/L - ENDIF - - IF(BR(I).LT.0.)GOTO 310 ! go to unstable regime (class 4) - IF(BR(I).EQ.0.)GOTO 280 ! go to neutral regime (class 3) -! -!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: -! - REGIME(I)=1. -! -! ... paj: psim and psih. Follows Cheng and Brutsaert 2005 (CB05). -! - psim(I)=psim_stable(zolzz)-psim_stable(zol0) - psih(I)=psih_stable(zolzz)-psih_stable(zol0) -! - psim10(I)=psim_stable(zol10)-psim_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) -! - psim2(I)=psim_stable(zol2)-psim_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) -! -! ... paj: preparations to compute PSIQ. Follows CB05+Carlson Boland JAM 1978. -! - pq(I)=psih_stable(zol(I))-psih_stable(zl) - pq2(I)=psih_stable(zl2)-psih_stable(zl) - pq10(I)=psih_stable(zl10)-psih_stable(zl) -! -! 1.0 over Monin-Obukhov length - RMOL(I)=ZOL(I)/ZA(I) -! - - GOTO 320 -! -!-----CLASS 3; FORCED CONVECTION: -! - 280 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) -! -! paj: preparations to compute PSIQ. -! - pq(I)=PSIH(I) - pq2(I)=PSIH2(I) - pq10(I)=0. -! - ZOL(I)=0. - RMOL(I) = ZOL(I)/ZA(I) - - GOTO 320 -! -!-----CLASS 4; FREE CONVECTION: -! - 310 CONTINUE - REGIME(I)=4. -! -! ... paj: PSIM and PSIH ... -! - psim(I)=psim_unstable(zolzz)-psim_unstable(zol0) - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) -! - psim10(I)=psim_unstable(zol10)-psim_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) -! - psim2(I)=psim_unstable(zol2)-psim_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) -! -! ... paj: preparations to compute PSIQ -! - pq(I)=psih_unstable(zol(I))-psih_unstable(zl) - pq2(I)=psih_unstable(zl2)-psih_unstable(zl) - pq10(I)=psih_unstable(zl10)-psih_unstable(zl) -! -!---LIMIOT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS -!--- THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL - PSIH(I)=AMIN1(PSIH(I),0.9*GZ1OZ0(I)) - PSIM(I)=AMIN1(PSIM(I),0.9*GZ1OZ0(I)) - PSIH2(I)=AMIN1(PSIH2(I),0.9*GZ2OZ0(I)) - PSIM10(I)=AMIN1(PSIM10(I),0.9*GZ10OZ0(I)) -! -! AHW: mods to compute ck, cd - PSIH10(I)=AMIN1(PSIH10(I),0.9*GZ10OZ0(I)) - - RMOL(I) = ZOL(I)/ZA(I) - - 320 CONTINUE -! -!-----COMPUTE THE FRICTIONAL VELOCITY: -! ZA(1982) EQS(2.60),(2.61). -! - DO 330 I=its,ite - DTG=THX(I)-THGB(I) - PSIX=GZ1OZ0(I)-PSIM(I) - PSIX10=GZ10OZ0(I)-PSIM10(I) - -! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL -! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 -! PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) - PSIT=GZ1OZ0(I)-PSIH(I) - PSIT2=GZ2OZ0(I)-PSIH2(I) -! - IF((XLAND(I)-1.5).GE.0)THEN - ZL=ZNT(I) - ELSE - ZL=0.01 - ENDIF -! - PSIQ=ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-pq(I) - PSIQ2=ALOG(KARMAN*UST(I)*2./XKA+2./ZL)-pq2(I) - -! AHW: mods to compute ck, cd - PSIQ10=ALOG(KARMAN*UST(I)*10./XKA+10./ZL)-pq10(I) - -! V3.7: using Fairall 2003 to compute z0q and z0t over water: -! adapted from module_sf_mynn.F - IF ( (XLAND(I)-1.5).GE.0. ) THEN - VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 - RESTAR=UST(I)*ZNT(I)/VISC - Z0T = (5.5e-5)*(RESTAR**(-0.60)) - Z0T = MIN(Z0T,1.0e-4) - Z0T = MAX(Z0T,2.0e-9) - Z0Q = Z0T - -! following paj: - zolzz=zol(I)*(za(I)+z0t)/za(I) ! (z+z0t)/L - zol10=zol(I)*(10.+z0t)/za(I) ! (10+z0t)/L - zol2=zol(I)*(2.+z0t)/za(I) ! (2+z0t)/L - zol0=zol(I)*z0t/za(I) ! z0t/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif - PSIT=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I) - PSIT2=ALOG((2.+z0t)/Z0t)-PSIH2(I) - - zolzz=zol(I)*(za(I)+z0q)/za(I) ! (z+z0q)/L - zol10=zol(I)*(10.+z0q)/za(I) ! (10+z0q)/L - zol2=zol(I)*(2.+z0q)/za(I) ! (2+z0q)/L - zol0=zol(I)*z0q/za(I) ! z0q/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0q)/Z0q)-PSIH(I) - PSIQ2=ALOG((2.+z0q)/Z0q)-PSIH2(I) - PSIQ10=ALOG((10.+z0q)/Z0q)-PSIH10(I) - ENDIF - - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.EQ.1 .AND. (XLAND(I)-1.5).GE.0. ) THEN -! v3.1 -! Z0Q = 1.e-4 + 1.e-3*(MAX(0.,UST(I)-1.))**2 -! hfip1 -! Z0Q = 0.62*2.0E-5/UST(I) + 1.E-3*(MAX(0.,UST(I)-1.5))**2 -! v3.2 - Z0Q = 1.e-4 -! -! ... paj: recompute psih for z0q -! - zolzz=zol(I)*(za(I)+z0q)/za(I) ! (z+z0q)/L - zol10=zol(I)*(10.+z0q)/za(I) ! (10+z0q)/L - zol2=zol(I)*(2.+z0q)/za(I) ! (2+z0q)/L - zol0=zol(I)*z0q/za(I) ! z0q/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0q)/Z0Q)-PSIH(I) - PSIT=PSIQ - PSIQ2=ALOG((2.+z0q)/Z0Q)-PSIH2(I) - PSIQ10=ALOG((10.+z0q)/Z0Q)-PSIH10(I) - PSIT2=PSIQ2 - ENDIF - IF ( ISFTCFLX.EQ.2 .AND. (XLAND(I)-1.5).GE.0. ) THEN -! AHW: Garratt formula: Calculate roughness Reynolds number -! Kinematic viscosity of air (linear approc to -! temp dependence at sea level) -! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which -! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60 - VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 -!! VISC=1.5E-5 - RESTAR=UST(I)*ZNT(I)/VISC - GZ0OZT=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.71)-5.) -! -! ... paj: compute psih for z0t for temperature ... -! - z0t=znt(I)/exp(GZ0OZT) -! - zolzz=zol(I)*(za(I)+z0t)/za(I) ! (z+z0t)/L - zol10=zol(I)*(10.+z0t)/za(I) ! (10+z0t)/L - zol2=zol(I)*(2.+z0t)/za(I) ! (2+z0t)/L - zol0=zol(I)*z0t/za(I) ! z0t/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! -! PSIT=GZ1OZ0(I)-PSIH(I)+RESTAR2 -! PSIT2=GZ2OZ0(I)-PSIH2(I)+RESTAR2 - PSIT=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I) - PSIT2=ALOG((2.+z0t)/Z0t)-PSIH2(I) -! - GZ0OZQ=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.60)-5.) - z0q=znt(I)/exp(GZ0OZQ) -! - zolzz=zol(I)*(za(I)+z0q)/za(I) ! (z+z0q)/L - zol10=zol(I)*(10.+z0q)/za(I) ! (10+z0q)/L - zol2=zol(I)*(2.+z0q)/za(I) ! (2+z0q)/L - zol0=zol(I)*z0q/za(I) ! z0q/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0q)/Z0q)-PSIH(I) - PSIQ2=ALOG((2.+z0q)/Z0q)-PSIH2(I) - PSIQ10=ALOG((10.+z0q)/Z0q)-PSIH10(I) -! PSIQ=GZ1OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2. -! PSIQ2=GZ2OZ0(I)-PSIH2(I)+2.28*SQRT(SQRT(RESTAR))-2. -! PSIQ10=GZ10OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2. - ENDIF - ENDIF - IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN - Ck(I)=(karman/psix10)*(karman/psiq10) - Cd(I)=(karman/psix10)*(karman/psix10) - Cka(I)=(karman/psix)*(karman/psiq) - Cda(I)=(karman/psix)*(karman/psix) - ENDIF - IF ( PRESENT(IZ0TLND) ) 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 if iz0tlnd = 1 -! If iz0tlnd = 2, use traditional value - - IF ( IZ0TLND.EQ.1 ) THEN - CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) - ELSE IF ( IZ0TLND.EQ.2 ) THEN - CZIL = 0.1 - END IF -! -! ... paj: compute phish for z0t over land -! - z0t=znt(I)/exp(CZIL*KARMAN*SQRT(RESTAR)) -! - zolzz=zol(I)*(za(I)+z0t)/za(I) ! (z+z0t)/L - zol10=zol(I)*(10.+z0t)/za(I) ! (10+z0t)/L - zol2=zol(I)*(2.+z0t)/za(I) ! (2+z0t)/L - zol0=zol(I)*z0t/za(I) ! z0t/L -! - if (zol(I).gt.0.) then - psih(I)=psih_stable(zolzz)-psih_stable(zol0) - psih10(I)=psih_stable(zol10)-psih_stable(zol0) - psih2(I)=psih_stable(zol2)-psih_stable(zol0) - else - if (zol(I).eq.0) then - psih(I)=0. - psih10(I)=0. - psih2(I)=0. - else - psih(I)=psih_unstable(zolzz)-psih_unstable(zol0) - psih10(I)=psih_unstable(zol10)-psih_unstable(zol0) - psih2(I)=psih_unstable(zol2)-psih_unstable(zol0) - endif - endif -! - PSIQ=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I) - PSIQ2=ALOG((2.+z0t)/Z0t)-PSIH2(I) - PSIT=PSIQ - PSIT2=PSIQ2 -! -! PSIT=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) -! PSIQ=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) -! PSIT2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR) -! PSIQ2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR) - - ENDIF - ENDIF -! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE - UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX -! TKE coupling: compute ust without vconv for use in tke scheme - WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I)) - IF ( PRESENT(USTM) ) THEN - USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX - ENDIF - - U10(I)=UX(I)*PSIX10/PSIX - V10(I)=VX(I)*PSIX10/PSIX - TH2(I)=THGB(I)+DTG*PSIT2/PSIT - Q2(I)=QSFC(I)+(QX(I)-QSFC(I))*PSIQ2/PSIQ - T2(I) = TH2(I)*(PSFCPA(I)/P1000mb)**ROVCP -! - IF((XLAND(I)-1.5).LT.0.)THEN - UST(I)=AMAX1(UST(I),0.001) - ENDIF - MOL(I)=KARMAN*DTG/PSIT/PRT - DENOMQ(I)=PSIQ - DENOMQ2(I)=PSIQ2 - DENOMT2(I)=PSIT2 - FM(I)=PSIX - FH(I)=PSIT - 330 CONTINUE -! - 335 CONTINUE - -!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: - IF ( PRESENT(SCM_FORCE_FLUX) ) THEN - IF (SCM_FORCE_FLUX.EQ.1) GOTO 350 - ENDIF - DO i=its,ite - QFX(i)=0. - HFX(i)=0. - ENDDO - 350 CONTINUE - - IF (ISFFLX.EQ.0) GOTO 410 - -!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). - - DO 360 I=its,ite - IF((XLAND(I)-1.5).GE.0)THEN -! ZNT(I)=CZO*UST(I)*UST(I)/G+OZO - ! PSH - formulation for depth-dependent roughness from - ! ... Jimenez and Dudhia, 2018 - IF ( shalwater_z0 .eq. 1 ) THEN - ZNT(I) = depth_dependent_z0(water_depth(I),ZNT(I),UST(I)) - ELSE - ! 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) - ENDIF -! COARE 3.5 (Edson et al. 2013) -! CZC = 0.0017*WSPD(I)-0.005 -! CZC = min(CZC,0.028) -! ZNT(I)=CZC*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) -! AHW: change roughness length, and hence the drag coefficients Ck and Cd - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.NE.0 ) THEN -! ZNT(I)=10.*exp(-9.*UST(I)**(-.3333)) -! ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333)) -! ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01) -! ZNT(I)=0.011*UST(I)*UST(I)/G+OZO -! ZNT(I)=MAX(ZNT(I),3.50e-5) -! AHW 2012: - ZW = MIN((UST(I)/1.06)**(0.3),1.0) - ZN1 = 0.011*UST(I)*UST(I)/G + OZO - ZN2 = 10.*exp(-9.5*UST(I)**(-.3333)) + & - 0.11*1.5E-5/AMAX1(UST(I),0.01) - ZNT(I)=(1.0-ZW) * ZN1 + ZW * ZN2 - ZNT(I)=MIN(ZNT(I),2.85e-3) - ZNT(I)=MAX(ZNT(I),1.27e-7) - ENDIF - ENDIF - ZL = ZNT(I) - ELSE - ZL = 0.01 - ENDIF - FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/DENOMQ(I) -! FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/( & -! ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-PSIH(I)) - DTTHX=ABS(THX(I)-THGB(I)) - IF(DTTHX.GT.1.E-5)THEN - FLHC(I)=CPM(I)*RHOX(I)*UST(I)*MOL(I)/(THX(I)-THGB(I)) -! write(*,1001)FLHC(I),CPM(I),RHOX(I),UST(I),MOL(I),THX(I),THGB(I),I - 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) - ELSE - FLHC(I)=0. - ENDIF - 360 CONTINUE - -! -!-----COMPUTE SURFACE MOIST FLUX: -! -! IF(IDRY.EQ.1)GOTO 390 -! - IF ( PRESENT(SCM_FORCE_FLUX) ) THEN - IF (SCM_FORCE_FLUX.EQ.1) GOTO 405 - ENDIF - - DO 370 I=its,ite - QFX(I)=FLQC(I)*(QSFC(I)-QX(I)) - QFX(I)=AMAX1(QFX(I),0.) - LH(I)=XLV*QFX(I) - 370 CONTINUE - -!-----COMPUTE SURFACE HEAT FLUX: -! - 390 CONTINUE - DO 400 I=its,ite - IF(XLAND(I)-1.5.GT.0.)THEN - HFX(I)=FLHC(I)*(THGB(I)-THX(I)) -! IF ( PRESENT(ISFTCFLX) ) THEN -! IF ( ISFTCFLX.NE.0 ) THEN -! AHW: add dissipative heating term (commented out in 3.6.1) -! HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I) -! ENDIF -! ENDIF - ELSEIF(XLAND(I)-1.5.LT.0.)THEN - HFX(I)=FLHC(I)*(THGB(I)-THX(I)) - HFX(I)=AMAX1(HFX(I),-250.) - ENDIF - 400 CONTINUE - - 405 CONTINUE - - DO I=its,ite - IF((XLAND(I)-1.5).GE.0)THEN - ZL=ZNT(I) - ELSE - ZL=0.01 - ENDIF -!v3.1.1 -! CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & -! /XKA+ZA(I)/ZL)-PSIH(I)) - CHS(I)=UST(I)*KARMAN/DENOMQ(I) -! GZ2OZ0(I)=ALOG(2./ZNT(I)) -! PSIM2(I)=-10.*GZ2OZ0(I) -! PSIM2(I)=AMAX1(PSIM2(I),-10.) -! PSIH2(I)=PSIM2(I) -! v3.1.1 -! CQS2(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*2.0 & -! /XKA+2.0/ZL)-PSIH2(I)) -! CHS2(I)=UST(I)*KARMAN/(GZ2OZ0(I)-PSIH2(I)) - CQS2(I)=UST(I)*KARMAN/DENOMQ2(I) - CHS2(I)=UST(I)*KARMAN/DENOMT2(I) - ENDDO - - 410 CONTINUE -!jdf -! DO I=its,ite -! IF(UST(I).GE.0.1) THEN -! RMOL(I)=RMOL(I)*(-FLHC(I))/(UST(I)*UST(I)*UST(I)) -! ELSE -! RMOL(I)=RMOL(I)*(-FLHC(I))/(0.1*0.1*0.1) -! ENDIF -! ENDDO -!jdf - -! - END SUBROUTINE SFCLAYREV1D - -!==================================================================== - SUBROUTINE sfclayrevinit(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) - - INTEGER :: N - REAL :: zolf - - INTEGER, INTENT(IN) :: ims,ime,jms,jme,its,ite,jts,jte - INTEGER, INTENT(IN) :: shalwater_z0 - REAL, INTENT(IN) :: shalwater_depth - INTEGER, INTENT(IN) :: bathymetry_flag - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: water_depth - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xland - INTEGER :: LakeModel - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lake_depth - REAL, DIMENSION( ims:ime, jms:jme ) :: lakemask - - DO N=0,1000 -! stable function tables - zolf = float(n)*0.01 - psim_stab(n)=psim_stable_full(zolf) - psih_stab(n)=psih_stable_full(zolf) - -! unstable function tables - zolf = -float(n)*0.01 - psim_unstab(n)=psim_unstable_full(zolf) - psih_unstab(n)=psih_unstable_full(zolf) - - ENDDO - IF ( shalwater_z0 .EQ. 1 ) THEN - CALL shalwater_init(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) - END IF - - END SUBROUTINE sfclayrevinit - - SUBROUTINE shalwater_init(ims,ime,jms,jme, & - its,ite,jts,jte, & - bathymetry_flag, shalwater_z0, & - shalwater_depth, water_depth, & - xland,LakeModel,lake_depth,lakemask ) - - INTEGER, INTENT(IN) :: ims,ime,jms,jme,its,ite,jts,jte - INTEGER, INTENT(IN) :: shalwater_z0 - REAL, INTENT(IN) :: shalwater_depth - INTEGER, INTENT(IN) :: bathymetry_flag - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: water_depth - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xland - INTEGER :: LakeModel - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: lake_depth - REAL, DIMENSION( ims:ime, jms:jme ) :: lakemask - - ! Local - LOGICAL :: overwrite_water_depth - - overwrite_water_depth = .False. - - IF ( bathymetry_flag .eq. 1 ) THEN - IF ( shalwater_depth .LE. 0.0 ) THEN - IF ( LakeModel .ge. 1 ) THEN - DO j = jts,jte - DO i = its,ite - IF ( lakemask(i,j) .EQ. 1 ) THEN - water_depth(i,j) = lake_depth(i,j) - END IF - END DO - END DO - END IF - ELSE - overwrite_water_depth = .True. - END IF - ELSE - IF ( shalwater_depth .GT. 0.0 ) THEN - overwrite_water_depth = .True. - ELSE - CALL wrf_error_fatal('No bathymetry data detected and shalwater_depth not greater than 0.0. Re-run WPS to get bathymetry data or set shalwater_depth > 0.0') - END IF - END IF - - IF (overwrite_water_depth) THEN - DO j = jts,jte - DO i = its,ite - IF((XLAND(i,j)-1.5).GE.0)THEN - water_depth(i,j) = shalwater_depth - ELSE - water_depth(i,j) = -2.0 - END IF - END DO - END DO - END IF - - END SUBROUTINE shalwater_init - - function zolri(ri,z,z0) -! - if (ri.lt.0.)then - x1=-5. - x2=0. - else - x1=0. - x2=5. - endif -! - fx1=zolri2(x1,ri,z,z0) - fx2=zolri2(x2,ri,z,z0) - iter = 0 - Do While (abs(x1 - x2) > 0.01) - if (iter .eq. 10) return -! check added for potential divide by zero (2019/11) - if(fx1.eq.fx2)return - if(abs(fx2).lt.abs(fx1))then - x1=x1-fx1/(fx2-fx1)*(x2-x1) - fx1=zolri2(x1,ri,z,z0) - zolri=x1 - else - x2=x2-fx2/(fx2-fx1)*(x2-x1) - fx2=zolri2(x2,ri,z,z0) - zolri=x2 - endif -! - iter = iter + 1 - enddo -! - - return - end function - -! -! ----------------------------------------------------------------------- -! - function zolri2(zol2,ri2,z,z0) -! - if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 -! - zol20=zol2*z0/z ! z0/L - zol3=zol2+zol20 ! (z+z0)/L -! - if (ri2.lt.0) then - psix2=log((z+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) - psih2=log((z+z0)/z0)-(psih_unstable(zol3)-psih_unstable(zol20)) - else - psix2=log((z+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) - psih2=log((z+z0)/z0)-(psih_stable(zol3)-psih_stable(zol20)) - endif -! - zolri2=zol2*psih2/psix2**2-ri2 -! - return - end function -! -! ... integrated similarity functions ... -! - function psim_stable_full(zolf) - psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) - return - end function - - function psih_stable_full(zolf) - psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) - return - end function - - function psim_unstable_full(zolf) - x=(1.-16.*zolf)**.25 - psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) -! - ym=(1.-10.*zolf)**0.33 - psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) -! - psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) - - return - end function - - function psih_unstable_full(zolf) - y=(1.-16.*zolf)**.5 - psihk=2.*log((1+y)/2.) -! - yh=(1.-34.*zolf)**0.33 - psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) -! - psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) - - return - end function - -! look-up table functions - function psim_stable(zolf) - integer :: nzol - real :: rzol - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) - else - psim_stable = psim_stable_full(zolf) - endif - return - end function - - function psih_stable(zolf) - integer :: nzol - real :: rzol - nzol = int(zolf*100.) - rzol = zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) - else - psih_stable = psih_stable_full(zolf) - endif - return - end function - - function psim_unstable(zolf) - integer :: nzol - real :: rzol - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) - else - psim_unstable = psim_unstable_full(zolf) - endif - return - end function - - function psih_unstable(zolf) - integer :: nzol - real :: rzol - nzol = int(-zolf*100.) - rzol = -zolf*100. - nzol - if(nzol+1 .lt. 1000)then - psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) - else - psih_unstable = psih_unstable_full(zolf) - endif - return - end function - - function depth_dependent_z0(water_depth,z0,UST) - real :: depth_b - real :: effective_depth - IF ( water_depth .lt. 10.0 ) THEN - effective_depth = 10.0 - ELSEIF ( water_depth .gt. 100.0 ) THEN - effective_depth = 100.0 - ELSE - effective_depth = water_depth - ENDIF - - depth_b = 1 / 30.0 * log (1260.0 / effective_depth) - depth_dependent_z0 = exp((2.7 * ust - 1.8 / depth_b) / (ust + 0.17 / depth_b) ) - depth_dependent_z0 = MIN(depth_dependent_z0,0.1) - return - end function -!------------------------------------------------------------------- - -END MODULE module_sf_sfclayrev - -! -! ---------------------------------------------------------- -! - - + ) + + 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 + +!================================================================================================================= + 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_timestep_init OK' + errflg = 0 + + end subroutine sf_sfclayrev_pre_run + +!================================================================================================================= + end module module_sf_sfclayrev +!================================================================================================================= diff --git a/phys/module_sf_urban.F b/phys/module_sf_urban.F index f7c04091a4..193e1cfda1 100644 --- a/phys/module_sf_urban.F +++ b/phys/module_sf_urban.F @@ -9,6 +9,8 @@ MODULE module_sf_urban #define WRITE_MESSAGE(M) call wrf_message( M ) #endif +USE module_model_constants, ONLY : piconst + !=============================================================================== ! Single-Layer Urban Canopy Model for WRF Noah-LSM ! Original Version: 2002/11/06 by Hiroyuki Kusaka @@ -88,6 +90,7 @@ MODULE module_sf_urban INTEGER :: IMP_SCHEME, IRI_SCHEME INTEGER :: alhoption ! anthropogenic latent heat option INTEGER :: groption ! anthropogenic latent heat option + LOGICAL :: distributed_aerodynamics_option REAL :: fgr ! green roof fraction REAL :: oasis ! urban oasis parameter REAL, DIMENSION(1:4) :: DZGR ! Layer depth of green roof @@ -316,7 +319,8 @@ SUBROUTINE urban(LSOLAR, & ! L 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) + DRELR,DRELB,DRELG,FLXHUMR,FLXHUMB,FLXHUMG, & + lf_urb_s, z0_urb, vegfrac_in) IMPLICIT NONE @@ -397,6 +401,13 @@ SUBROUTINE urban(LSOLAR, & ! L REAL, INTENT(INOUT), DIMENSION(4) :: lf_urb ! frontal area index [-] REAL, INTENT(INOUT) :: zo_check ! check for printing ZOC +!------------------------------------------------------------------------------- +! I: Distributed aerodynamics parameters +!------------------------------------------------------------------------------- + REAL, INTENT(IN) :: lf_urb_s ! frontal area index [-] + REAL, INTENT(IN) :: z0_urb ! roughness length [m] + REAL, INTENT(IN) :: vegfrac_in ! vegetation fraction (0 to 1) [-] + !------------------------------------------------------------------------------- ! O: output variables from Urban to LSM !------------------------------------------------------------------------------- @@ -544,10 +555,12 @@ SUBROUTINE urban(LSOLAR, & ! L REAL :: PSIX, PSIT, PSIX2, PSIT2, PSIX10, PSIT10 REAL :: TRP, TBP, TGP, TCP, QCP, TST, QST + REAL :: TSP, CHS_LOCAL, CHS2_LOCAL REAL :: WDR,HGT2,BW,DHGT REAL, parameter :: VonK = 0.4 REAL :: lambda_f,alpha_macd,beta_macd,lambda_fr + REAL :: lambda_p, vegfrac INTEGER :: iteration, K, NUDAPT INTEGER :: tloc, tloc2, Kalh @@ -595,6 +608,14 @@ SUBROUTINE urban(LSOLAR, & ! L integer,parameter :: IMPB = 2 integer,parameter :: IMPG = 3 + SHADOW = .false. +! SHADOW = .true. + + IF (distributed_aerodynamics_option .and. groption == 1) THEN + FATAL_ERROR("slucm_distributed_drag is not compatible with groption") + END IF + + !------------------------------------------------------------------------------- ! Set parameters !------------------------------------------------------------------------------- @@ -626,7 +647,7 @@ SUBROUTINE urban(LSOLAR, & ! L ! Glotfelty, 2012/07/05, NUDAPT Modification - if(mh_urb.gt.0.0)THEN + if (mh_urb.gt.0.0 .and. .not. distributed_aerodynamics_option) THEN !write(mesg,*) 'Mean Height NUDAPT',mh_urb !WRITE_MESSAGE(mesg) !write(mesg,*) 'Mean Height Table',ZR @@ -783,6 +804,25 @@ SUBROUTINE urban(LSOLAR, & ! L endif if(alhoption==1) ALH = ALH*alhdiuprf(tloc2)*alhseason(Kalh) + IF (distributed_aerodynamics_option) THEN + ZDC = 0. + IF (Z0_URB > MH_URB) THEN + FATAL_ERROR("Z0_URB is larger than MH_URB") + END IF + ZR = MAX(MH_URB, 3.5) + Z0C = MAX(Z0_URB, 0.1) + lambda_p = MAX(0.05, MIN(1.0, LP_URB)) + lambda_f = MAX(0.05, MIN(1.0, LF_URB_S)) + + R = lambda_p + RW = 1 - R + SVF = kanda_kawai_svf(lambda_p, lambda_f) + + vegfrac = MIN(0.9, MAX(0.1, vegfrac_in)) + + HGT = lambda_f + END IF + 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 @@ -818,6 +858,8 @@ SUBROUTINE urban(LSOLAR, & ! L TCP=TC QCP=QC + TSP = (TR * R + TB * W + TG * RW) / (R + RW + W) + !===Yang,2014/10/08, urban hydrological variables for single layer UCM=== FLXHUMRP = FLXHUMR FLXHUMBP = FLXHUMB @@ -865,9 +907,6 @@ SUBROUTINE urban(LSOLAR, & ! L ! Net Short Wave Radiation at roof, wall, and road !------------------------------------------------------------------------------- - SHADOW = .false. -! SHADOW = .true. - IF (SSG > 0.0) THEN IF(.NOT.SHADOW) THEN ! no shadow effects model @@ -968,9 +1007,22 @@ SUBROUTINE urban(LSOLAR, & ! L ! note that CHR_URB contains UA (=CHR_MOS*UA) RLMO_URB=0.0 + IF (distributed_aerodynamics_option) THEN + T1VC = TSP* (1.0+ 0.61 * QA) + CALL SFCDIF_URB (ZA,Z0C,T1VC,TH2V,UA,AKANDA_URBAN,CMC_URB,CHC_URB,RLMO_URB,CDC,Z0HC,vegfrac) + CHC = CHC_URB / UA ! canopy bulk transfer coef. + ALPHAC = RHO * CP * CHC_URB + CHR = CHC * R / (R + W + RW) ! local bulk transfer coef for roof + CHB = CHC * W / (R + W + RW) ! local bulk transfer coef for building wall + CHG = CHC * RW / (R + W + RW) ! local bulk transfer coef for floor + ALPHAR = RHO * CP * CHR * UA + ALPHAB = RHO * CP * CHB * UA + ALPHAG = RHO * CP * CHG * UA + ELSE CALL SFCDIF_URB (ZA,Z0R,T1VR,TH2V,UA,AKANDA_URBAN,CMR_URB,CHR_URB,RLMO_URB,CDR) ALPHAR = RHO*CP*CHR_URB CHR=ALPHAR/RHO/CP/UA + END IF ! Yang, 03/12/2014 -- LH for impervious roof surface RAIN1 = RAIN * 0.001 /3600 ! CONVERT FROM mm/hr to m/s @@ -1190,6 +1242,8 @@ SUBROUTINE urban(LSOLAR, & ! L ! CALL mos(XXXC,ALPHAC,CDC,BHC,RIBC,Z,Z0C,UA,TA,TCP,RHO) ! Virtual temperatures needed by SFCDIF routine from Noah + IF (.not. distributed_aerodynamics_option) THEN + T1VC = TCP* (1.0+ 0.61 * QA) RLMO_URB=0.0 CALL SFCDIF_URB(ZA,Z0C,T1VC,TH2V,UA,AKANDA_URBAN,CMC_URB,CHC_URB,RLMO_URB,CDC) @@ -1219,6 +1273,8 @@ SUBROUTINE urban(LSOLAR, & ! L CHB=ALPHAB/RHO/CP/UC CHG=ALPHAG/RHO/CP/UC + END IF + !Yang 10/10/2013 -- LH from impervious wall and ground IF (IMP_SCHEME==1) then BETB=0.0 @@ -1279,7 +1335,7 @@ SUBROUTINE urban(LSOLAR, & ! L ES=6.11*EXP( (2.5*10.**6./461.51)*(TGP-273.15)/(273.15*TGP) ) DESDT=(2.5*10.**6./461.51)*ES/(TGP**2.) QS0G=0.622*ES/(PS-0.378*ES) - DQS0GDTG=DESDT*0.22*PS/((PS-0.378*ES)**2.) + DQS0GDTG=DESDT*0.622*PS/((PS-0.378*ES)**2.) RG1=EPSG*( RX*VFGS & +EPSB*VFGW*SIG*TBP**4./60. & @@ -1297,7 +1353,7 @@ SUBROUTINE urban(LSOLAR, & ! L RB2=EPSB*( (1.-EPSG)*VFWG*VFGS*RX & +(1.-EPSG)*EPSB*VFGW*VFWG*SIG*(TBP**4.)/60. & +(1.-EPSB)*VFWS*(1.-2.*VFWS)*RX & - +(1.-EPSB)*VFWG*(1.-2.*VFWS)*EPSG*SIG*EPSG*TGP**4./60. & + +(1.-EPSB)*VFWG*(1.-2.*VFWS)*SIG*EPSG*TGP**4./60. & +EPSB*(1.-EPSB)*(1.-2.*VFWS)*(1.-2.*VFWS)*SIG*TBP**4./60. ) RG=RG1+RG2 @@ -1319,6 +1375,23 @@ SUBROUTINE urban(LSOLAR, & ! L DRGDTB=DRGDTB1+DRGDTB2 DRGDTG=DRGDTG1+DRGDTG2 + IF (distributed_aerodynamics_option) THEN + HB=RHO*CP*CHB*UA*(TBP-TA)*100. + HG=RHO*CP*CHG*UA*(TGP-TA)*100. + + DHBDTB=RHO*CP*CHB*UA*100. + DHBDTG=0. + DHGDTG=RHO*CP*CHG*UA*100. + DHGDTB=0. + + ELEB=RHO*EL*CHB*UA*BETB*(QS0B-QA)*100. + ELEG=RHO*EL*CHG*UA*BETG*(QS0G-QA)*100. + + DELEBDTB=RHO*EL*CHB*UA*BETB*DQS0BDTB*100. + DELEBDTG=0. + DELEGDTG=RHO*EL*CHG*UA*BETG*DQS0GDTG*100. + DELEGDTB=0. + ELSE HB=RHO*CP*CHB*UC*(TBP-TCP)*100. HG=RHO*CP*CHG*UC*(TGP-TCP)*100. @@ -1340,6 +1413,7 @@ SUBROUTINE urban(LSOLAR, & ! L DELEBDTG=RHO*EL*CHB*UC*BETB*(0.-DQCDTG)*100. DELEGDTG=RHO*EL*CHG*UC*BETG*(DQS0GDTG-DQCDTG)*100. DELEGDTB=RHO*EL*CHG*UC*BETG*(0.-DQCDTB)*100. + ENDIF G0B=AKSB*(TBP-TBL(1))/(DZB(1)/2.) G0G=AKSG*(TGP-TGL(1))/(DZG(1)/2.) @@ -1366,6 +1440,9 @@ SUBROUTINE urban(LSOLAR, & ! L TBP = TB TGP = TG + IF (distributed_aerodynamics_option) THEN + DTC = 0.0 + ELSE TC1=RW*ALPHAC+RW*ALPHAG+W*ALPHAB TC2=RW*ALPHAC*TA+RW*ALPHAG*TGP+W*ALPHAB*TBP TC=TC2/TC1 @@ -1377,6 +1454,7 @@ SUBROUTINE urban(LSOLAR, & ! L DTC=TCP - TC TCP=TC QCP=QC + END IF IF( ABS(F) < 0.000001 .AND. ABS(DTB) < 0.000001 & .AND. ABS(GF) < 0.000001 .AND. ABS(DTG) < 0.000001 & @@ -1416,7 +1494,7 @@ SUBROUTINE urban(LSOLAR, & ! L RB2=EPSB*( (1.-EPSG)*VFWG*VFGS*RX & +(1.-EPSG)*EPSB*VFGW*VFWG*SIG*(TBP**4.)/60. & +(1.-EPSB)*VFWS*(1.-2.*VFWS)*RX & - +(1.-EPSB)*VFWG*(1.-2.*VFWS)*EPSG*SIG*EPSG*TGP**4./60. & + +(1.-EPSB)*VFWG*(1.-2.*VFWS)*SIG*EPSG*TGP**4./60. & +EPSB*(1.-EPSB)*(1.-2.*VFWS)*(1.-2.*VFWS)*SIG*TBP**4./60. ) RG=RG1+RG2 @@ -1484,7 +1562,11 @@ SUBROUTINE urban(LSOLAR, & ! L else FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG ) endif + IF (distributed_aerodynamics_option) THEN + FLXUV = CDC * UA * UA + ELSE FLXUV = ( R*CDR + RW*CDC )*UA*UA + END IF FLXG = ( R*G0R + W*G0B + RW*G0G ) LNET = R*RR + W*RB + RW*RG endif @@ -1532,14 +1614,20 @@ SUBROUTINE urban(LSOLAR, & ! L GZ1OZ0 = ALOG(Z/Z0) CD = 0.4**2./(ALOG(Z/Z0)-PSIM)**2. + CHS_LOCAL = 0.4 * UST / (ALOG(Z / Z0H) - PSIH) ! !m CH = 0.4**2./(ALOG(Z/Z0)-PSIM)/(ALOG(Z/Z0H)-PSIH) !m CHS = 0.4*UST/(ALOG(Z/Z0H)-PSIH) !m TS = TA + FLXTH/CH/UA ! surface potential temp (flux temp) !m QS = QA + FLXHUM/CH/UA ! surface humidity ! + IF (distributed_aerodynamics_option) THEN + TS = TA + FLXTH / (ALPHAC / (RHO * CP)) ! surface potential temp (flux temp) + QS = QA + FLXHUM / (ALPHAC / (RHO * CP)) ! surface humidity + ELSE TS = TA + FLXTH/CHS ! surface potential temp (flux temp) QS = QA + FLXHUM/CHS ! surface humidity + END IF !------------------------------------------------------- ! diagnostic GRID AVERAGED U10 V10 TH2 Q2 --> WRF @@ -1589,9 +1677,14 @@ SUBROUTINE urban(LSOLAR, & ! L ! TH2 = TS + (TA-TS)*(PSIT2/PSIT) ! potential temp at 2 m [K] ! TH2 = TS + (TA-TS)*(PSIT2/PSIT) ! Fei: this seems to be temp (not potential) at 2 m [K] !Fei: consistant with M-O theory + IF (distributed_aerodynamics_option) THEN + CHS2_LOCAL = 0.4 * UST / (ALOG(2. / Z0H) - PSIH2) + TH2 = TS + (TA - TS) * (CHS_LOCAL / CHS2_LOCAL) + Q2 = QS + (QA - QS) * (CHS_LOCAL / CHS2_LOCAL) + ELSE TH2 = TS + (TA-TS) *(CHS/CHS2) - Q2 = QS + (QA-QS)*(PSIT2/PSIT) ! humidity at 2 m [-] + END IF ! TS = (LW/SIG_SI/0.88)**0.25 ! Radiative temperature [K] @@ -1947,7 +2040,7 @@ END SUBROUTINE read_param ! !=============================================================================== SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & - sf_urban_physics,use_wudapt_lcz) + sf_urban_physics,use_wudapt_lcz, slucm_distributed_drag) ! num_roof_layers,num_wall_layers,num_road_layers) IMPLICIT NONE @@ -1962,6 +2055,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZG INTEGER, INTENT(IN) :: SF_URBAN_PHYSICS INTEGER, INTENT(IN) :: USE_WUDAPT_LCZ !AndreaLCZ + LOGICAL, INTENT(IN) :: slucm_distributed_drag INTEGER :: LC, K INTEGER :: IOSTATUS, ALLOCATE_STATUS @@ -1999,6 +2093,8 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & ICATE=0 + distributed_aerodynamics_option = slucm_distributed_drag + if(USE_WUDAPT_LCZ.eq.0)then !AndreaLCZ OPEN (UNIT=11, & @@ -2647,6 +2743,14 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, !m !FS FRC_URB2D(I,J)=0. UTYPE_URB2D(I,J)=0 + + distributed_aerodynamics_check: IF (distributed_aerodynamics_option) THEN + IF (IVGTYP(I, J) == ISURBAN) THEN + UTYPE_URB2D(I, J) = 2 + ELSE + UTYPE_URB2D(I, J) = 0 + END IF + ELSE SWITCH_URB=1 IF( IVGTYP(I,J) == ISURBAN) THEN @@ -2729,6 +2833,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, ENDDO ENDIF ENDIF + END IF distributed_aerodynamics_check QC_URB2D(I,J)=0.01 @@ -3007,7 +3112,7 @@ SUBROUTINE bisection(TSP,PS,S,EPS,RX,SIG,RHO,CP,CH,UA,QA,TA,EL,BET,AKS,TSL,DZ,TS END SUBROUTINE bisection !=========================================================================== -SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) +SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD,ZT_OUT,VEGFRAC) ! ---------------------------------------------------------------------- ! SUBROUTINE SFCDIF_URB (Urban version of SFCDIF_off) @@ -3026,6 +3131,8 @@ SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) REAL SFCSPD, AKANDA, AKMS, AKHS, ZU, ZT, RDZ, CXCH REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 + REAL, INTENT(OUT), OPTIONAL :: ZT_OUT + REAL, INTENT(IN), OPTIONAL :: VEGFRAC !CC ......REAL ZTFC REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & @@ -3107,7 +3214,12 @@ SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) ! ---------------------------------------------------------------------- ! KCL/TL Try Kanda approach instead (Kanda et al. 2007, JAMC) ! ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + IF (PRESENT(VEGFRAC)) THEN + ! Kawai et al. (2009) JAMC + ZT = EXP (2.0-(AKANDA-0.9*VEGFRAC**0.29)*(SQVISC**2 * USTAR * Z0)**0.25)* Z0 + ELSE ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0 + END IF ZSLU = ZLM + ZU @@ -3176,7 +3288,12 @@ SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) !KCL/TL !ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + IF (PRESENT(VEGFRAC)) THEN + ! Kawai et al. (2009) JAMC + ZT = EXP (2.0-(AKANDA-0.9*VEGFRAC**0.29)*(SQVISC**2 * USTAR * Z0)**0.25)* Z0 + ELSE ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0 + END IF ZSLT = ZLM + ZT RLOGT = log (ZSLT / ZT) USTARK = USTAR * VKRM @@ -3200,6 +3317,8 @@ SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) END DO CD = USTAR*USTAR/SFCSPD**2 + + IF (PRESENT(ZT_OUT)) ZT_OUT = ZT ! ---------------------------------------------------------------------- END SUBROUTINE SFCDIF_URB ! ---------------------------------------------------------------------- @@ -4055,5 +4174,17 @@ SUBROUTINE TDFCND (DF, SMC, QZ, SMCMAX) ! ---------------------------------------------------------------------- END SUBROUTINE TDFCND ! ---------------------------------------------------------------------- + + FUNCTION kanda_kawai_svf(lp, lf) RESULT (svf) + IMPLICIT NONE + real, intent(in) :: lp, lf + real :: hovl, vloc, vmod, svf + + hovl = lf * lp ** (-0.5) / (1. - lp ** 0.5) + vloc = cos(atan(2. * hovl)) * (2. - 4. / piconst * atan(cos(atan(2. * hovl)))) + vmod = 0.1120 * lp * vloc - 0.4817 * lp + 0.0246 * vloc + 0.9570 + svf = vloc * vmod + END FUNCTION kanda_kawai_svf + !=========================================================================== END MODULE module_sf_urban diff --git a/phys/module_surface_driver.F b/phys/module_surface_driver.F index f1592a1f00..650dd4fe87 100644 --- a/phys/module_surface_driver.F +++ b/phys/module_surface_driver.F @@ -32,7 +32,7 @@ SUBROUTINE surface_driver( & & ,zs & & ,albsi, icedepth,snowsi & & ,xicem,isice,iswater,ct,tke_pbl & - & ,albbck,embck,lh,sh2o,shdmax,shdmin,z0 & + & ,albbck,embck,lh,sh2o,shdmax,shdmin,shdavg,z0 & & ,flqc,flhc,psfc,sst,sst_input,sstsk,dtw,sst_update,sst_skin & & ,scm_force_skintemp,scm_force_flux,t2,emiss & & ,sf_sfclay_physics,sf_surface_physics,ra_lw_physics & @@ -257,6 +257,7 @@ SUBROUTINE surface_driver( & & ,bldt,curr_secs,adapt_step_flag,bldtacttime & ! Optional urban with BEP & ,sf_urban_physics,gmt,xlat,xlong,julday & + & ,distributed_ahe_opt, ahe & !For anthropogenic heat & ,num_urban_ndm & !multi-layer urban & ,urban_map_zrd & !multi-layer urban & ,urban_map_zwd & !multi-layer urban @@ -270,6 +271,7 @@ SUBROUTINE surface_driver( & & ,urban_map_zgrd & !multi-layer urban & ,num_urban_hi & !multi-layer urban & ,use_wudapt_lcz & !wudapt + & ,slucm_distributed_drag & !SLUCM & ,tsk_rural & !multi-layer urban & ,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d & !multi-layer urban & ,tlev_urb3d,qlev_urb3d & !multi-layer urban @@ -288,6 +290,7 @@ SUBROUTINE surface_driver( & & ,swddir,swddif & !gl & ,lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d & !multi-layer urban & ,mh_urb2d,stdh_urb2d,lf_urb2d & + & ,lf_urb2d_s, z0_urb2d & & ,a_u_bep,a_v_bep,a_t_bep,a_q_bep & & ,b_u_bep,b_v_bep,b_t_bep,b_q_bep & & ,sf_bep,vl_bep & @@ -393,6 +396,7 @@ SUBROUTINE surface_driver( & USE module_sf_tmnupdate USE module_sf_lake USE module_cpl, ONLY : coupler_on, cpl_rcv + use module_ra_gfdleta, only: cal_mon_day ! ! This driver calls subroutines for the surface parameterizations. ! @@ -870,6 +874,7 @@ SUBROUTINE surface_driver( & REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: SH2O REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDAVG REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ):: Z0 ! NoahMP specific fields @@ -939,6 +944,8 @@ SUBROUTINE surface_driver( & ! Variables for multi-layer UCM REAL, OPTIONAL, INTENT(IN ) :: GMT INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY + INTEGER, INTENT(IN) :: distributed_ahe_opt + REAL, OPTIONAL, DIMENSION( ims:ime, 0:287, jms:jme ), INTENT(IN) :: ahe REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG INTEGER , INTENT(IN) :: num_urban_ndm INTEGER , INTENT(IN) :: urban_map_zrd @@ -953,6 +960,7 @@ SUBROUTINE surface_driver( & INTEGER , INTENT(IN) :: urban_map_zgrd INTEGER, INTENT(IN ):: NUM_URBAN_HI INTEGER, INTENT(IN ):: use_wudapt_lcz + LOGICAL, INTENT(IN ):: slucm_distributed_drag REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural 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 @@ -997,6 +1005,8 @@ SUBROUTINE surface_driver( & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: mh_urb2d !urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: stdh_urb2d!urban REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN) :: lf_urb2d !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lf_urb2d_s !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: z0_urb2d !urban 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 @@ -1449,20 +1459,19 @@ SUBROUTINE surface_driver( & real, optional, dimension(ims:ime,jms:jme ),intent(inout) :: XLAIDYN ! IRRIGATION - INTEGER :: tloc, jmonth,timing - REAL, PARAMETER :: PI_GRECO=3.14159 - INTEGER :: end_hour, irr_start,xt24,irr_day - REAL :: constants_irrigation + INTEGER :: ihour, jmonth, jday REAL, DIMENSION( ims:ime, jms:jme ) :: IRRIGATION_CHANNEL REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) , OPTIONAL:: IRRIGATION REAL, INTENT(IN),OPTIONAL:: irr_daily_amount - INTEGER :: phase INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT),OPTIONAL :: irr_rand_field INTEGER, INTENT(IN ),OPTIONAL:: sf_surf_irr_scheme,irr_start_hour,irr_num_hours,irr_start_julianday,irr_end_julianday,irr_freq,irr_ph ! WRF-Solar EPS real, dimension (:, :, :), allocatable :: smois_tmp, tslb_tmp +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg ! !------------------------------------------------------------------ ! Initialize local variables @@ -1883,7 +1892,7 @@ SUBROUTINE surface_driver( & decided = .TRUE. END IF - IF ( run_param ) then + run_param_if: IF ( run_param ) then radiation = .false. frpcpn = .false. @@ -2039,7 +2048,7 @@ SUBROUTINE surface_driver( & u10,v10,th2,t2,q2, & gz1oz0,wspd,br,isfflx,dx2d, & svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + P1000mb,lakemask, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -2057,7 +2066,7 @@ SUBROUTINE surface_driver( & u10,v10,th2,t2,q2, & gz1oz0,wspd,br,isfflx,dx2d, & svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + P1000mb,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & @@ -2090,9 +2099,9 @@ SUBROUTINE surface_driver( & znt,ust,pblh,mavail,zol,mol,regime,psim,psih,fm,fhh, & xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & u10,v10,th2,t2,q2, & - gz1oz0,wspd,br,isfflx,dx, & - svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + gz1oz0,wspd,br,isfflx,dx2d, & + svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & + P1000mb,lakemask, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -2101,23 +2110,23 @@ SUBROUTINE surface_driver( & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux,sf_surface_physics ) + shalwater_z0,water_depth, & + scm_force_flux,sf_surface_physics,errmsg,errflg ) ELSE CALL SFCLAYREV(u_phytmp,v_phytmp,t_phy,qv_curr,& p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, & znt,ust,pblh,mavail,zol,mol,regime,psim,psih,fm,fhh, & xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & u10,v10,th2,t2,q2, & - gz1oz0,wspd,br,isfflx,dx, & - svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, & - P1000mb, & + gz1oz0,wspd,br,isfflx,dx2d, & + svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & + P1000mb,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux ) + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg ) #if ( EM_CORE==1) DO j = j_start(ij),j_end(ij) DO i = i_start(ij),i_end(ij) @@ -2664,7 +2673,7 @@ SUBROUTINE surface_driver( & myj,frpcpn, & sh2o,snowh, & !h u_phy,v_phy, & !I - snoalb,shdmin,shdmax, & !i + snoalb,shdmin,shdmax,shdavg, & !i snotime, & !o acsnom,acsnow, & !o snopcx, & !o @@ -2733,6 +2742,7 @@ SUBROUTINE surface_driver( & urban_map_zgrd, & !I multi-layer urban num_urban_hi, & !I multi-layer urban use_wudapt_lcz, & !I wudapt + slucm_distributed_drag, & !I SLUCM tsk_rural, & !H multi-layer urban trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban tlev_urb3d,qlev_urb3d, & !H multi-layer urban @@ -2748,6 +2758,7 @@ SUBROUTINE surface_driver( & lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !GRZ lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban mh_urb2d,stdh_urb2D,lf_urb2d, & !SLUCM + lf_urb2d_s, z0_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 @@ -2880,6 +2891,7 @@ SUBROUTINE surface_driver( & lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !GRZ lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban mh_urb2d,stdh_urb2D,lf_urb2d, & !SLUCM + lf_urb2d_s, z0_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 @@ -3217,6 +3229,7 @@ SUBROUTINE surface_driver( & dgr_urb3d, dg_urb3d, lfr_urb3d, lfg_urb3d, & !GRZ lp_urb2d, hi_urb2d, lb_urb2d, hgt_urb2d, & !H multi-layer urban mh_urb2d, stdh_urb2d, lf_urb2d, & !SLUCM + lf_urb2d_s, z0_urb2d, vegfra, & !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 @@ -4469,7 +4482,22 @@ SUBROUTINE surface_driver( & ENDIF ENDIF - ENDIF + IF (distributed_ahe_opt == 2) THEN + call cal_mon_day(julday, julyr, jmonth, jday) + ihour = (jmonth - 1) * 24 + MOD(INT(gmt + xtime / 60.0), 24) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1, num_tiles + DO j = j_start(ij), j_end(ij) + DO i = i_start(ij), i_end(ij) + HFX(i, j) = HFX(i, j) + ahe(i, ihour, j) + END DO + END DO + END DO + !$OMP END PARALLEL DO + END IF + + ENDIF run_param_if END SUBROUTINE surface_driver @@ -5796,10 +5824,10 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & FM,FH, & XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, & U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & + GZ1OZ0,WSPD,BR,ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000, & + KARMAN, & + P1000,LAKEMASK, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -5808,8 +5836,8 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux,sf_surface_physics ) + shalwater_z0,water_depth, & + scm_force_flux,sf_surface_physics,errmsg,errflg) USE module_sf_sfclayrev implicit none @@ -5820,7 +5848,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, INTENT(IN ) :: ISFFLX REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN ) :: EP1,EP2,KARMAN,EOMEG,STBOLT + REAL, INTENT(IN ) :: EP1,EP2,KARMAN REAL, INTENT(IN ) :: P1000 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & @@ -5835,6 +5863,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & @@ -5859,7 +5888,8 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & V3D REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: PSFC + INTENT(IN ) :: PSFC, & + DX2D REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ZNT, & @@ -5877,7 +5907,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(INOUT) :: & QGH - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda @@ -5886,7 +5916,6 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX,IZ0TLND INTEGER, INTENT(IN ) :: shalwater_z0 - REAL, INTENT(IN ) :: shalwater_depth REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN ) :: water_depth INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX @@ -5977,11 +6006,15 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & WSPD_SEA, & ZOL_SEA +! To accommodate shared physics + character*256 :: errmsg + integer :: errflg + ! INTENT(IN) to SFCLAY; unchanged by the call ! ISFFLX ! SVP1,SVP2,SVP3,SVPT0 - ! EP1,EP2,KARMAN,EOMEG,STBOLT - ! CP,G,ROVCP,R,XLV,DX + ! EP1,EP2,KARMAN + ! CP,G,ROVCP,R,XLV,DX2D ! ISFTCFLX,IZ0TLND ! P1000 ! dz8w @@ -6058,16 +6091,16 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & FM,FH, & XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, & U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & + GZ1OZ0,WSPD,BR,ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000, & + KARMAN, & + P1000,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,shalwater_depth, & - scm_force_flux ) + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg ) ! !Restore land-point values calculated by SSiB (fds 12/2010) IF (itimestep .gt. 1 .and. sf_surface_physics .EQ. 8) then @@ -6152,16 +6185,16 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA, & ! I/O U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea, & ! O GZ1OZ0_SEA,WSPD_SEA,BR_SEA, & ! I/O - ISFFLX,DX, & + ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,EOMEG,STBOLT, & - P1000, & + KARMAN, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ! 0 ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd,& - shalwater_z0,water_depth,shalwater_depth, & - scm_force_flux ) + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg ) ! DO j = JTS , JTE DO i = ITS, ITE @@ -6230,7 +6263,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000, & + P1000,lakemask, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -6265,6 +6298,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & + LAKEMASK, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & @@ -6491,7 +6525,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -6585,7 +6619,7 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & - P1000, & + P1000,lakemask, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ! 0 diff --git a/phys/module_wind_fitch.F b/phys/module_wind_fitch.F index e2b4bb3049..3adaa8274c 100644 --- a/phys/module_wind_fitch.F +++ b/phys/module_wind_fitch.F @@ -518,6 +518,7 @@ SUBROUTINE init_module_wind_fitch(id,config_flags,xlong,xlat,windfarm_initialize CALL wrf_dm_bcast_real(hubheight,nt) CALL wrf_dm_bcast_real(diameter,nt) CALL wrf_dm_bcast_real(stc,nt) + CALL wrf_dm_bcast_real(stc2,nt) CALL wrf_dm_bcast_real(npower,nt) CALL wrf_dm_bcast_real(cutin,nt) CALL wrf_dm_bcast_real(cutout,nt) diff --git a/phys/module_wind_mav.F b/phys/module_wind_mav.F new file mode 100644 index 0000000000..dabb6f1e36 --- /dev/null +++ b/phys/module_wind_mav.F @@ -0,0 +1,2085 @@ +!WRF:MODEL_LAYER:PHYSICS + +MODULE module_wind_mav +! +! Represents kinetic energy extracted by wind turbines and turbulence +! (TKE) they produce at model levels within the rotor area. +! This module is based on module_wind_fitch but uses the Jensen, XA and Gm wake +! loss models instead of the Fitch parameterization + +! Code by Yulong MA (Guangdong-Hong kong-Macau Greater Bay Area Weather +! Research Center for Monitoring Warning and Forecasting;UDEL) and Cristina L. Archer (UDEL) + +! --- NOTICE --- +! The following papers should be cited whenever presenting results using this scheme: +! Ma, Yulong, Cristina L. Archer, and Ahmadreza Vasel-Be-Hagh. "The Jensen wind +! farm parameterization." Wind Energy Science 7.6 (2022): 2407-2431. +! Ma, Yulong, Cristina L. Archer, and Ahmad Vasel‐Be‐Hagh. "Comparison of +! individual versus ensemble wind farm parameterizations inclusive of sub‐grid +! wakes for the WRF model." Wind Energy 25.9 (2022): 1573-1595. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + +#if defined(mpas) + use mpas_dmpar + use mpas_derived_types + + IMPLICIT NONE + INTEGER, PARAMETER :: max_domains = 1 + REAL, PARAMETER :: piconst = 3.141593 + logical, save :: windfarm_initialized = .false. ! MPAS +#else + + USE module_driver_constants, ONLY : max_domains + USE module_model_constants, ONLY : piconst + + USE module_llxy + USE module_dm, ONLY : wrf_dm_min_real, wrf_dm_sum_reals + USE module_configure, ONLY : grid_config_rec_type + + + IMPLICIT NONE +#endif + + INTEGER, PARAMETER :: MAXVALS = 100 + INTEGER :: nt + INTEGER, DIMENSION(:), ALLOCATABLE :: NKIND, NVAL + INTEGER, DIMENSION(:,:), ALLOCATABLE :: ival,jval ! grid number in WRF + REAL, DIMENSION(:), ALLOCATABLE :: hubheight, radius, radius2, diameter, area,& + stc, stc2, cutin, cutout, npower + REAL, DIMENSION(:,:), ALLOCATABLE :: xturb, yturb ! (nt, maxdomain) + REAL, DIMENSION(:,:), ALLOCATABLE :: turbws, turbtc, turbpw, turbpwcof ! (nt,maxvals) + + REAL :: correction_factor + + CONTAINS + + !====================================================================== + + subroutine dragforce_mav(itimestep & + &,id & + &,z_at_w,z_at_m,u,v & + &,dx,dz,dt,tke & + &,du,dv & + &,windfarm_opt,power & + &,windfarm_wake_model, windfarm_overlap_method & + &,xland & +#if defined(mpas) + &,dminfo & + &,windfarm_ij, windfarm_deg & + &,xcell, ycell & +#else + &,cosa,sina & +#endif + &,ids,ide,jds,jde,kds,kde & + &,ims,ime,jms,jme,kms,kme & + &,its,ite,jts,jte,kts,kte & + &) + + implicit none + + integer, intent(in) :: id,windfarm_opt, windfarm_wake_model, windfarm_overlap_method + integer, intent(in) :: its,ite,jts,jte,kts,kte + integer, intent(in) :: ims,ime,jms,jme,kms,kme + integer, intent(in) :: ids,ide,jds,jde,kds,kde + real, intent(in) :: dx, dt + real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: dz, u, v, z_at_w, z_at_m + real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: du, dv, tke + real, dimension(ims:ime,jms:jme), intent(in) :: xland + real, dimension(ims:ime,jms:jme), intent(inout) :: power + integer, intent(in) :: itimestep + + real, dimension(ims:ime,kms:kme,jms:jme) :: Uearth, Vearth ! earth-relative u and v + +#if defined(mpas) + type(dm_info),intent(in) :: dminfo + integer, intent(in) :: windfarm_ij + real, intent(in) :: windfarm_deg + real, dimension(ims:ime, jms:jme), intent(in) :: xcell, ycell !hexgon cell center +#else + real, dimension(ims:ime,jms:jme), intent(in) :: cosa,sina +#endif + + ! Local + real :: wfdensity + integer :: itf, jtf, i, j, k + integer :: wake_model, num_models, overlap_method + integer :: wake_model_en(5), overlap_method_en(5) + real, dimension(kms:kme) :: z_tmp + real, dimension(ims:ime,kms:kme,jms:jme) :: tke_wk, du_wk, dv_wk + + real :: kw_nt(nt) + real :: search_angle, search_dis + integer :: ii, tt, kt + integer :: num_ups_pot(nt), ups_indx_pot(nt,nt) ! potential ups turbines + real :: avg_angle_tb(nt,nt) ! potential ups turbines + + integer :: tbindx(nt), num_ups(nt), ups_index(nt,nt) + real :: ao_ups(nt,nt), ax_dist(nt,nt), ay_dist(nt,nt), az_dist(nt,nt) + real :: blockfrac(nt), blockdist(nt), rblockdist(nt), ytb_rot_gm(nt,nt) ! GM + logical :: find_tb + real :: u_hub_nt(nt), v_hub_nt(nt), Uinf(nt), ulocal(nt), xland_nt(nt), terrain_nt(nt) + real :: power_nt(nt), power_nt_md(5,nt) + + ! dir avg + integer, parameter :: dir_num = 7 + real, parameter :: dir_avg_window = 5.0 ! +- 2.5 unit [degree] + integer :: dir_ii + real :: dtheta + real :: dtheta_list(7) ! [-2.5, -1.5, -0.5, 0., 0.5, 1.5, 2.5] + real :: dtheta_avg_cof(7) !gaussian distribution + real :: dtheta_std !gaussian distribution std + + ! parallel computing + real :: dm_local_u_hub_nt(nt), dm_global_u_hub_nt(nt) + real :: dm_local_v_hub_nt(nt), dm_global_v_hub_nt(nt) + real :: dm_local_xland_nt(nt), dm_global_xland_nt(nt) + real :: dm_local_terrain_nt(nt), dm_global_terrain_nt(nt) + integer :: ic_tb + + integer,save :: n_valid_cur = 0 + integer :: tb_valid_cur(nt) + + +#if defined(mpas) + wfdensity = 1.0/(dx*dx*sqrt(3.)/2.) +#else + wfdensity = 1.0/(dx*dx) +#endif + + tb_valid_cur(:) = 1 ! set all tbs in operation + + !--------------------------------------------- + ! Gaussion distribution direction avg + dtheta_list(1) = -2.5; dtheta_list(7) = 2.5; + dtheta_list(2) = -1.5; dtheta_list(6) = 1.5; + dtheta_list(3) = -0.5; dtheta_list(5) = 0.5; + dtheta_list(4) = 0. + + dtheta_std = 2.0 ! std [deg] + dtheta_avg_cof(1) = exp(-dtheta_list(1)**2/(2.*dtheta_std**2)) + dtheta_avg_cof(2) = exp(-dtheta_list(2)**2/(2.*dtheta_std**2)) + dtheta_avg_cof(3) = exp(-dtheta_list(3)**2/(2.*dtheta_std**2)) + dtheta_avg_cof(4) = 1. + dtheta_avg_cof(7) = dtheta_avg_cof(1) + dtheta_avg_cof(6) = dtheta_avg_cof(2) + dtheta_avg_cof(5) = dtheta_avg_cof(3) + + dtheta_avg_cof(:) = dtheta_avg_cof(:)/sum(dtheta_avg_cof) + !--------------------------------------------- + + ! + ! for parallel computing + ! + itf = MIN0(ite,ide-1) + jtf = MIN0(jte,jde-1) + + dm_local_u_hub_nt(:) = 0. + dm_local_v_hub_nt(:) = 0. + dm_local_xland_nt(:) = 0. + dm_local_terrain_nt(:) = 0. + dm_global_u_hub_nt(:) = 0. + dm_global_v_hub_nt(:) = 0. + dm_global_xland_nt(:) = 0. + dm_global_terrain_nt(:) = 0. + ic_tb = 0 + +#if defined(mpas) + do kt = 1, nt + i = ival(kt,id) + j = jval(kt,id) + if (i >= its .and. i <= itf .and. j >= jts .and. j <= jtf) then + ic_tb = ic_tb + 1 + z_tmp = z_at_m(i,:,j) - z_at_w(i,1,j) ! mass point height + call to_zk2(hubheight(kt), z_tmp(1:kme-1), u(i,1:kme-1,j), kme-1, dm_local_u_hub_nt(kt)) + call to_zk2(hubheight(kt), z_tmp(1:kme-1), v(i,1:kme-1,j), kme-1, dm_local_v_hub_nt(kt)) + end if + end do + call mpas_dmpar_sum_real_array(dminfo, nt, dm_local_u_hub_nt, dm_global_u_hub_nt) + call mpas_dmpar_sum_real_array(dminfo, nt, dm_local_v_hub_nt, dm_global_v_hub_nt) + +#else + + + ! ---- WRF grid related wind direction to earth related direction --- + ! for Non Mercator projection, the wind direction should be rotated to earth + ! coordinates (where U would be west-east and V would be north-south) + ! https://www2.mmm.ucar.edu/wrf/users/FAQ_files/Miscellaneous.html + DO j = jts, min(jte,jde-1) + DO k = kts, kte-1 + DO i = its, min(ite,ide-1) + Uearth(i,k,j) = U(i,k,j)*cosa(i,j) - V(i,k,j)*sina(i,j) + Vearth(i,k,j) = V(i,k,j)*cosa(i,j) + U(i,k,j)*sina(i,j) + ENDDO + ENDDO + ENDDO + + do kt = 1, nt + i = ival(kt,id) + j = jval(kt,id) + if (i >= its .and. i <= itf .and. j >= jts .and. j <= jtf) then + ic_tb = ic_tb + 1 + z_tmp = z_at_m(i,:,j) - z_at_w(i,1,j) ! mass point height + call to_zk2(hubheight(kt), z_tmp(1:kme-1), Uearth(i,1:kme-1,j), kme-1, dm_local_u_hub_nt(kt)) + call to_zk2(hubheight(kt), z_tmp(1:kme-1), Vearth(i,1:kme-1,j), kme-1, dm_local_v_hub_nt(kt)) + + dm_local_xland_nt(kt) = xland(i,j) + dm_local_terrain_nt(kt) = z_at_w(i,1,j) + end if + + ! if turbine kt is out of the whole domain (i or j == -9999), assume it is not at + ! upstream of any turbines (distance >= 20D), set xturb, yturb to a large value + ! and set uhub, vhub to a small value. It should have no effects on the rest of turbines. + if (i == -9999 .or. j == -9999) then + tb_valid_cur(kt) = 0 + dm_local_u_hub_nt(kt) = 1.e-3 + dm_local_v_hub_nt(kt) = 1.e-3 + endif + end do + + call wrf_dm_sum_reals(dm_local_u_hub_nt, dm_global_u_hub_nt) + call wrf_dm_sum_reals(dm_local_v_hub_nt, dm_global_v_hub_nt) + call wrf_dm_sum_reals(dm_local_xland_nt, dm_global_xland_nt) + call wrf_dm_sum_reals(dm_local_terrain_nt, dm_global_terrain_nt) +#endif + + u_hub_nt(:) = dm_global_u_hub_nt(:) + v_hub_nt(:) = dm_global_v_hub_nt(:) + xland_nt(:) = dm_global_xland_nt(:) + terrain_nt(:) = dm_global_terrain_nt(:) + + !if (ic_tb == 0) return ! no turbine in this tile, no need to do the rest part + + + ! + ! potential ups turbines in a fan-shaped region + ! + Uinf(:) = sqrt(u_hub_nt(:)**2 + v_hub_nt(:)**2) ! hub height speed + + search_angle = 30.*piconst/180. ! +-30 deg, a wider region because of wind dir avg + search_dis = 20.*diameter(1) ! 20D + num_ups_pot(:) = 0 + do kt = 1, nt + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + ii = 0 + do tt = 1, nt + if (tt == kt) cycle + find_tb = find_turb(xturb(kt,id), yturb(kt,id), xturb(tt,id), yturb(tt,id), & + u_hub_nt(kt), v_hub_nt(kt), search_angle, search_dis) + if (find_tb) then + ii = ii + 1 + ups_indx_pot(kt, ii) = tt + avg_angle_tb(kt, tt) = atan2(v_hub_nt(kt)+v_hub_nt(tt), u_hub_nt(kt)+u_hub_nt(tt)) + end if + end do + num_ups_pot(kt) = ii + end do + + + ! + ! dir avg start + ! + tke_wk(:,:,:) = 0. + du_wk(:,:,:) = 0. + dv_wk(:,:,:) = 0. + power(:,:) = 0. + power_nt(:) = 0. ! output to a txt file + power_nt_md(:,:) = 0. ! output to a txt file + + !------------------- Ensemble --------------------- + if (windfarm_wake_model <= 3) then + num_models = 1 + wake_model_en(1) = windfarm_wake_model + overlap_method_en(1) = windfarm_overlap_method + + ! 1=JS, 2=XA, 3=GM + else if (windfarm_wake_model == 4) then ! JS-M4 + XA-M3 + num_models = 2 + wake_model_en(1) = 1; overlap_method_en(1) = 4 + wake_model_en(2) = 2; overlap_method_en(2) = 3 + + else if (windfarm_wake_model == 5) then ! JS-M4 + XA-M3 + GM + num_models = 3 + wake_model_en(1) = 1; overlap_method_en(1) = 4 + wake_model_en(2) = 2; overlap_method_en(2) = 3 + wake_model_en(3) = 3; overlap_method_en(3) = 2 + + else if (windfarm_wake_model == 6) then ! JS-M3 + JS-M4 + XA-M3 + GM, single-cell + num_models = 4 + wake_model_en(1) = 1; overlap_method_en(1) = 3 + wake_model_en(2) = 1; overlap_method_en(2) = 4 + wake_model_en(3) = 2; overlap_method_en(3) = 3 + wake_model_en(4) = 3; overlap_method_en(4) = 2 + + else if (windfarm_wake_model == 7) then ! JS-M4 + XA-M3 + XA-M4 + GM, multi-cell + num_models = 4 + wake_model_en(1) = 1; overlap_method_en(1) = 4 + wake_model_en(2) = 2; overlap_method_en(2) = 3 + wake_model_en(3) = 2; overlap_method_en(3) = 4 + wake_model_en(4) = 3; overlap_method_en(4) = 2 + end if + !------------------- Ensemble --------------------- + + do dir_ii = 1, dir_num ! dir avg loop + if (dir_num > 1) then + !dtheta = -(0.5*dir_avg_window - (dir_ii-1.)/(dir_num-1.)*dir_avg_window)/180.*piconst + dtheta = dtheta_list(dir_ii)/180.*piconst + else + dtheta = 0. + end if + + do ii = 1, num_models + wake_model = wake_model_en(ii) + overlap_method = overlap_method_en(ii) + + ! actual upstream turbines (overlap area > 0) + call ups_turbs(kw_nt, ao_ups, ax_dist, ay_dist, az_dist, ytb_rot_gm, ups_index, num_ups, & + num_ups_pot, ups_indx_pot, avg_angle_tb, xturb(:,id), yturb(:,id), & + radius, area, hubheight, xland_nt, terrain_nt, nt, dtheta, wake_model) + + ! sort all turbines from the most upstream turbine + ! NOT BASED on ax_dist because they are not at the same diretion. + ! (a directed graph problem) + call sort_turb(nt, num_ups, ups_index, tbindx) + + ! cal. def and local speed + if (wake_model == 1) then + call cal_tb_ulocal_JS(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, Ao_ups, kw_nt, nt, radius, tb_valid_cur, overlap_method) + + else if (wake_model == 2) then + call cal_tb_ulocal_XA(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, Ao_ups, & + nt, radius, radius2, tb_valid_cur, overlap_method) + + else if (wake_model == 3) then + call cal_tb_ulocal_GM(ulocal, blockfrac, blockdist, rblockdist, & + uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, ytb_rot_gm, & + nt, radius, tb_valid_cur) + end if + + ! cal power and WRF tendencies + call cal_power_wrf_tend(ulocal, uinf, tb_valid_cur, blockfrac, blockdist, u, v, dz, z_at_w, & + ival(:,id), jval(:,id), nt, radius, diameter, hubheight, area, & + wake_model, wfdensity, dt, & + power_nt_md(ii,:), power, tke_wk, du_wk, dv_wk, dtheta_avg_cof(dir_ii), & + ims,ime,jms,jme,kms,kme,its,itf,jts,jtf) + end do + end do + + tke_wk = tke_wk/num_models + du_wk = du_wk/num_models + dv_wk = dv_wk/num_models + power = power/num_models + + tke = tke_wk ! turbine generated TKE + du = du + du_wk + dv = dv + dv_wk + + do ii = 1, num_models + power_nt(:) = power_nt(:) + power_nt_md(ii,:) + enddo + power_nt = power_nt/num_models + + ! write fraction power of each turbine to a txt at 4 hr + !call write_power_txt(windfarm_wake_model, windfarm_overlap_method, itimestep, dt, its, jts, & + ! dx, power_nt, power_nt_md, ulocal, nt, num_models) + + end subroutine dragforce_mav + + +!============================================================================== +!============================================================================== + + + subroutine write_power_txt(windfarm_model, windfarm_method, itimestep, dt, its, jts, & + dx, power_nt, power_nt_md, ulocal, nt, num_models) + ! this function might be improved later. + implicit none + integer :: nt, windfarm_model, windfarm_method, itimestep, its, jts, num_models + real :: dx, power_nt(nt), ulocal(nt), power_nt_md(5,nt), dt + integer :: it_out, ii, i, j, kt + integer,save :: it_init = 0, write_out = 0 + character(len=1024) :: fmt_my, str_my, fn_my + real :: out_hr, max_power + + out_hr = 4. ! hr + + if (it_init == 0) it_init = itimestep + + write (str_my, "(I1)") windfarm_method + + IF (windfarm_model == 1) THEN + fn_my = 'power_nt_JS_M'//trim(str_my)//'.txt_5.0d_0.25' + ELSEIF (windfarm_model == 2) THEN + fn_my = 'power_nt_XA_M'//trim(str_my)//'.txt_5.0d_0.25' + ELSEIF (windfarm_model == 3) THEN + IF (windfarm_method == 2) fn_my = 'power_nt_GM_MC.txt_5.0d_0.25' + IF (windfarm_method == 3) fn_my = 'power_nt_GM_AN.txt_5.0d' + ENDIF + + IF (windfarm_model == 4) fn_my = 'power_nt_EN2.txt_5.0d_0.25' + IF (windfarm_model == 5) fn_my = 'power_nt_EN3.txt_5.0d_0.25' + + IF (windfarm_model == 6) fn_my = 'power_nt_EN6.txt_2.5d' + IF (windfarm_model == 7) fn_my = 'power_nt_EN7.txt_2.5d' + + + !if (itimestep == it_out .and. its == 1 .and. jts == 1) then + if ((itimestep-it_init)*dt >= 4.*3600. .and. write_out == 0 .and. its == 1 .and. jts == 1) then + write_out = 1 + + write(*,*) 'output relative power', (itimestep-it_init)*dt + OPEN ( FILE = fn_my, UNIT = 923) + write (str_my, "(I6)") nt + fmt_my = '('//trim(str_my)//'F12.2)' + + write(923,FMT=fmt_my) power_nt(1:nt) + + do ii = 1, num_models + write(923,FMT=fmt_my) power_nt_md(ii,1:nt) + end do + + write(923,FMT=fmt_my) ulocal(1:nt) + CLOSE(923) + + endif + end subroutine write_power_txt + +!--------------------------------------------------------------- + + subroutine ups_turbs( kw_nt, ao_ups, ax_dist, ay_dist, az_dist, ytb_rot_gm, ups_index, num_ups, & + num_ups_pot, ups_indx_pot, avg_angle_tb, xturb, yturb, & + radius, area, hubheight, xland_nt, terrain_nt, nt, dtheta, windfarm_model) + implicit none + integer, intent(in) :: nt, num_ups_pot(nt), ups_indx_pot(nt,nt), windfarm_model + real, intent(in) :: avg_angle_tb(nt,nt), xturb(nt), yturb(nt), & + radius(nt), area(nt), hubheight(nt), xland_nt(nt), terrain_nt(nt) + real, intent(out) :: ao_ups(nt,nt), ax_dist(nt,nt), ay_dist(nt,nt), az_dist(nt,nt), & + ytb_rot_gm(nt,nt), kw_nt(nt) + integer, intent(out) :: ups_index(nt,nt), num_ups(nt) + real :: dtheta + + integer :: num_ups_turb, tt, jt, kt, ii + real :: cur_tb_ang, ax_GM(nt), x_ups_tmp, y_ups_tmp, x_cur, y_cur, & + axialdist, Ao, wakewidth + real :: kw_tmp, kw_test(nt), kw + + !----------------------- + do kt = 1, nt + if (xland_nt(kt) > 1.5) then ! water = 2 + kw = 0.04 ! offshore + else if (xland_nt(kt) < 1.5) then ! land = 1 + kw = 0.0075 ! onshore + end if + + if (windfarm_model == 1) then + kw_test(kt) = kw + kw_nt(kt) = kw + else if (windfarm_model == 2) then + kw_test(kt) = 5.*kw ! choose a larger search region for XA + end if + end do + + if (windfarm_model == 3) then + kw_test(:) = 0. ! no wake expandation for GM + end if + !----------------------- + + + do kt = 1, nt + num_ups_turb = 0 + do tt = 1, num_ups_pot(kt) + + jt = ups_indx_pot(kt,tt) + + cur_tb_ang = avg_angle_tb(kt,jt) + dtheta + call coordinate_rotation(x_cur, y_cur, xturb(kt), yturb(kt), cur_tb_ang) + call coordinate_rotation(x_ups_tmp, y_ups_tmp, xturb(jt), yturb(jt), cur_tb_ang) + + axialdist = x_cur - x_ups_tmp + if (axialdist <= 0.) then + Ao = 0. + else + kw_tmp = kw_test(jt) + wakewidth = radius(jt) + kw_tmp*axialdist + Ao = AreaOverlap(y_cur, y_ups_tmp, hubheight(kt)+terrain_nt(kt), & + hubheight(jt)+terrain_nt(jt), radius(kt), wakewidth) + end if + + !if (Ao/area(kt) > 0.) then + if (Ao/area(kt) > 0.01) then + num_ups_turb = num_ups_turb + 1 + ups_index(kt,num_ups_turb) = jt + Ao_ups(kt,jt) = Ao/area(kt) + ax_dist(kt,jt) = axialdist + ay_dist(kt,jt) = y_cur - y_ups_tmp + az_dist(kt,jt) = (hubheight(kt) + terrain_nt(kt)) - & + (hubheight(jt) + terrain_nt(jt)) + + ax_gm(num_ups_turb) = axialdist ! for GM to sort ups turbines + ytb_rot_gm(kt,jt) = y_ups_tmp + end if + + ! used in analytical GM, it changes if ups turbines are + ! in different grid cells, just approximate value here. TO BE IMPROVED! + ytb_rot_gm(kt,kt) = y_cur + + end do + num_ups(kt) = num_ups_turb + + if (windfarm_model == 3 .and. num_ups(kt) > 1) then ! GM model + call sort_gm(num_ups(kt), ups_index(kt,1:num_ups(kt)), ax_gm(1:num_ups(kt))) + end if + + end do + + end subroutine ups_turbs + +!--------------------------------------------------------------- + + subroutine cal_tb_ulocal_JS(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, Ao_ups, kw_nt, nt, radius, tb_valid_cur, overlap_method) + implicit none + real, intent(out) :: ulocal(nt) + real, intent(in ) :: uinf(nt), Ao_ups(nt,nt), ax_dist(nt,nt), radius(nt), kw_nt(nt) + integer, intent(in) :: nt, tbindx(nt), num_ups(nt), ups_index(nt,nt), overlap_method + integer,intent(in) :: tb_valid_cur(nt) + + ! turbws, turbtc, turbpwcof, stc, stc2, nval are global varibles, not defined here + + integer :: kt, it, jt, tt, nv + real :: Udef_nt(nt), def_ij, tmp, thrcof + + ulocal(:) = uinf(:) + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interet + + if (num_ups(it) == 0) cycle + + Udef_nt(:) = 0. + do tt = 1, num_ups(it) + jt = ups_index(it,tt) + nv = nval(jt) + call dragcof(tmp, tmp, thrcof, ulocal(jt), turbws(jt,1:nv), & + turbtc(jt,1:nv), turbpwcof(jt,1:nv), stc(jt), stc2(jt), nv) + + def_ij = (1. - sqrt(1. - thrcof))/(1. + kw_nt(jt)*ax_dist(it,jt)/radius(jt))**2*Ao_ups(it,jt) + + ! wake overlapping methods M1 - M4 + if (overlap_method == 1 .or. overlap_method == 2) then + Udef_nt(jt) = uinf(jt)*def_ij*Ao_ups(it,jt) + + else if (overlap_method == 3) then + Udef_nt(jt) = ulocal(jt)*def_ij*Ao_ups(it,jt) + + ! Here Udef_nt is actually a local U, not a DeltaU + else if (overlap_method == 4) then + Udef_nt(jt) = uinf(it)*(1. - Ao_ups(it,jt)) + uinf(jt)*(1. - def_ij)*Ao_ups(it,jt) + end if + + end do + + if (overlap_method == 1) then + ulocal(it) = Uinf(it) - sum(Udef_nt) + else if (overlap_method == 2 .or. overlap_method == 3) then + ulocal(it) = Uinf(it) - sqrt(sum(Udef_nt**2)) + else if (overlap_method == 4) then + ulocal(it) = sqrt(sum(Udef_nt**2)/num_ups(it)) + end if + + enddo + + end subroutine cal_tb_ulocal_JS + +!--------------------------------------------------------------- + + subroutine cal_tb_ulocal_XA(ulocal, uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, Ao_ups, & + nt, radius, radius2, tb_valid_cur, overlap_method) + implicit none + real, intent(out) :: ulocal(nt) + real, intent(in ) :: uinf(nt), Ao_ups(nt,nt), ax_dist(nt,nt), ay_dist(nt,nt), & + az_dist(nt,nt), radius(nt), radius2(nt) + integer, intent(in) :: nt, tbindx(nt), num_ups(nt), ups_index(nt,nt), overlap_method + integer,intent(in) :: tb_valid_cur(nt) + + ! turbws, turbtc, turbpwcof, stc, stc2, nval are global varibles, not defined here + + real :: ky, kz + integer :: kt, it, jt, tt, nv + real :: Udef_nt(nt), def_ij, tmp, thrcof + real :: beta, eps, sigmay, sigmaz, def_avg + + ! --- Are ky and kz the same over land? + ky = 0.025 + kz = 0.0175 + + ulocal(:) = uinf(:) + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interet + + if (num_ups(it) == 0) cycle + + Udef_nt(:) = 0. + do tt = 1, num_ups(it) + jt = ups_index(it,tt) + nv = nval(jt) + call dragcof(tmp, tmp, thrcof, ulocal(jt), turbws(jt,1:nv), & + turbtc(jt,1:nv), turbpwcof(jt,1:nv), stc(jt), stc2(jt), nv) + + beta = 0.5*(1. + sqrt(1. - thrcof))/sqrt(1. - thrcof) + eps = 0.25*sqrt(beta) + sigmay = ky*ax_dist(it,jt) + eps*2*radius(jt) + sigmaz = kz*ax_dist(it,jt) + eps*2*radius(jt) + call Gaussian_integral(ay_dist(it,jt), az_dist(it,jt), radius(it), sigmay, sigmaz, def_avg) + def_ij = (1. - sqrt(1.-radius2(jt)*thrcof/sigmay/sigmaz/2.))*def_avg + + ! wake overlapping methods M1 - M4 + if (overlap_method == 1 .or. overlap_method == 2) then + Udef_nt(jt) = Uinf(jt)*def_ij + + else if (overlap_method == 3) then + Udef_nt(jt) = ulocal(jt)*def_ij + + ! Here Udef_nt is actually a local U, not a DeltaU + else if (overlap_method == 4) then + Udef_nt(jt) = Uinf(jt)*(1. - def_ij) + end if + end do + + if (overlap_method == 1) then + ulocal(it) = Uinf(it) - sum(Udef_nt) + else if (overlap_method == 2 .or. overlap_method == 3) then + ulocal(it) = Uinf(it) - sqrt(sum(Udef_nt**2)) + else if (overlap_method == 4) then + ulocal(it) = sqrt(sum(Udef_nt**2)/num_ups(it)) + end if + end do + + end subroutine cal_tb_ulocal_XA + +!--------------------------------------------------------------- + + subroutine cal_tb_ulocal_GM(ulocal, blockfrac, blockdist, rblockdist, & + uinf, tbindx, num_ups, ups_index, & + ax_dist, ay_dist, az_dist, ytb_rot_gm, & + nt, radius, tb_valid_cur) + implicit none + real, intent(out) :: ulocal(nt), blockfrac(nt), blockdist(nt), rblockdist(nt) + integer, intent(in) :: nt, tbindx(nt), num_ups(nt), ups_index(nt,nt) + real, intent(in) :: uinf(nt), ax_dist(nt,nt), ay_dist(nt,nt), az_dist(nt,nt), & + ytb_rot_gm(nt,nt), radius(nt) + integer,intent(in) :: tb_valid_cur(nt) + integer :: kt, it + real :: gfun_GM + + integer, parameter :: ndisk = 50 ! 50x50 samples for montecarlo + real, parameter :: MAXD = 20. ! upsteam within 20d + integer :: ii, jd, kd, jt, tt, nblock + integer :: ndiskpt + real :: diskpt(ndisk) + real :: distblk(ndisk,ndisk), rdistblk(ndisk,ndisk) + real :: scaled_axdist(nt), raxdist(nt) + integer :: on_disk(ndisk,ndisk) + real :: on_disk_1d(ndisk*ndisk) + real :: on_disk_1d_y(ndisk*ndisk), on_disk_1d_z(ndisk*ndisk) + real :: on_disk_1d_yr(ndisk*ndisk), on_disk_1d_zr(ndisk*ndisk) + real :: distblk_1d(ndisk*ndisk), rdistblk_1d(ndisk*ndisk) + + integer, parameter :: cal_method = 2 ! 1 : analytical, 2 = montecarlo + + ulocal(:) = uinf(:) + + if (cal_method == 2) then + + do ii = 1, ndisk + diskpt(ii) = -1. + (ii-0.5)/ndisk*2. + end do + + !on_disk(:,:) = 0 + on_disk_1d(:) = 0. + on_disk_1d_y(:) = 0. + on_disk_1d_z(:) = 0. + ndiskpt = 0 + do jd = 1, ndisk + do kd = 1, ndisk + if (diskpt(jd)**2 + diskpt(kd)**2 < 1.) then + ndiskpt = ndiskpt + 1 + !on_disk(jd,kd) = 1 + on_disk_1d(ndiskpt) = 1. + on_disk_1d_y(ndiskpt) = diskpt(jd) + on_disk_1d_z(ndiskpt) = diskpt(kd) + endif + end do + end do + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interest + + if (num_ups(it) == 0) then + blockfrac(it) = 0. + else + do tt = 1, num_ups(it) + jt = ups_index(it,tt) + scaled_axdist(jt) = ax_dist(it,jt)/(MAXD*2.*radius(jt)) ! scaled by 20*diameter + raxdist(jt) = 1./ax_dist(it,jt) + end do + + nblock = 0 + + on_disk_1d_yr(1:ndiskpt) = on_disk_1d_y(1:ndiskpt)*radius(it) + on_disk_1d_zr(1:ndiskpt) = on_disk_1d_z(1:ndiskpt)*radius(it) + + !--- montecarlo 1 --- + distblk_1d(1:ndiskpt) = on_disk_1d(1:ndiskpt) + rdistblk_1d(1:ndiskpt) = 0. + do ii = 1, ndiskpt ! on tb it + do tt = num_ups(it), 1, -1 ! starting from the closest turbine + jt = ups_index(it,tt) + if ((on_disk_1d_yr(ii) - ay_dist(it,jt))**2 + & ! on tb jt + (on_disk_1d_zr(ii) - az_dist(it,jt))**2 < radius2(jt)) then + nblock = nblock + 1 + distblk_1d(nblock) = scaled_axdist(jt) ! ax_dist(jt)/(20*diameter(it)) + rdistblk_1d(nblock) = raxdist(jt) ! 1./ax_dist(jt) + exit + end if + end do + end do + blockdist(it) = sum(distblk_1d(1:ndiskpt))/ndiskpt + rblockdist(it) = sum(rdistblk_1d(1:ndiskpt))/ndiskpt + !--- montecarlo 1 --- + + + !--- montecarlo 2 --- + !!on_disk and ndiskpt are the same for all turbines, already calculated + !!set distblk(jd,kd) = 1. on turbine (= 0 out of turbine) + !distblk(:,:) = on_disk(:,:)*1.0 + !rdistblk(:,:) = 0. + !do jd = 1, ndisk + !do kd = 1, ndisk + ! if (on_disk(jd,kd) == 1) then ! on turbine it + ! do tt = num_ups(it), 1, -1 ! starting from the closest turbine + ! jt = ups_index(it,tt) + ! if ((diskpt(jd)*radius(it) - ay_dist(it,jt))**2 + & ! on tb jt + ! (diskpt(kd)*radius(it) - az_dist(it,jt))**2 < radius2(jt)) then + ! nblock = nblock + 1 + ! distblk(jd,kd) = scaled_axdist(jt) ! ax_dist(jt)/(20*diameter(it)) + ! rdistblk(jd,kd) = raxdist(jt) ! 1./ax_dist(jt) + ! exit + ! end if + ! end do + ! end if + !end do + !end do + !blockdist(it) = sum(distblk)/ndiskpt + !rblockdist(it) = sum(rdistblk)/ndiskpt + !--- montecarlo 2 --- + + + blockfrac(it) = float(nblock)/ndiskpt + if (blockdist(it) > 1.) blockfrac(it) = 0. + end if ! num_ups(it) > 0 + + !--- + if (blockfrac(it) == 0.) then + gfun_GM = 1. + else + gfun_GM = 0.9615 - 0.1549*blockfrac(it) - 0.0114*rblockdist(it)*20.*2*radius(it) + end if + ulocal(it) = Uinf(it)*gfun_GM + enddo + endif + + + if (cal_method == 1) then + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + it = tbindx(kt) ! tb of interet + call gm_BD_BR_analytical(blockfrac(it), blockdist(it), rblockdist(it), & + radius(it), num_ups(it), ups_index(it,1:nt), nt, it, & + ax_dist(it,1:nt), ytb_rot_gm(it,1:nt)) + if (blockfrac(it) == 0.) then + gfun_GM = 1. + else + gfun_GM = 0.9615 - 0.1549*blockfrac(it) - 0.0114*rblockdist(it)*20.*2*radius(it) + end if + ulocal(it) = Uinf(it)*gfun_GM + enddo + endif + end subroutine cal_tb_ulocal_GM + +!--------------------------------------------------------------- + + subroutine cal_power_wrf_tend(ulocal, uinf, tb_valid_cur, blockfrac, blockdist, u, v, dz, z_at_w, & + ival, jval, nt, radius, diameter, hubheight, area, & + windfarm_model, wfdensity, dt, & + power_nt, power, tke_wk, du_wk, dv_wk, dtheta_avg_cof_i, & + ims,ime,jms,jme,kms,kme,its,itf,jts,jtf) + implicit none + integer :: ims, ime, jms, jme, kms, kme, its, itf, jts, jtf + real, dimension(ims:ime,kms:kme,jms:jme), intent(in) :: u, v, dz, z_at_w + real, dimension(ims:ime,kms:kme,jms:jme) :: tke_wk, du_wk, dv_wk ! wrf output + real, dimension(ims:ime,jms:jme) :: power ! wrf output + real :: power_nt(nt) ! output + real :: dtheta_avg_cof_i !gaussian distribution + + integer :: nt, ival(nt), jval(nt), windfarm_model + real :: ulocal(nt), Uinf(nt), blockfrac(nt), blockdist(nt) + real :: radius(nt), diameter(nt), hubheight(nt), area(nt), wfdensity, dt + integer :: tb_valid_cur(nt) + + integer :: kt, nv, i, j, k + real, dimension(kms:kme) :: speed_z, tarea_z, power2_z, z_tmp + real :: power_GM, power1, power2, ec, tkecof, powcof, thrcof + real :: blade_l_point,blade_u_point,z1,z2 + integer :: k_turbine_bot, k_turbine_top + real :: tmp_spd + + ! turbws, turbtc, turbpwcof, stc, stc2, nval are global varibles, not defined here + + do kt = 1, nt + + if (tb_valid_cur(kt) == 0) cycle ! turbine is turned off or outside of the domain + + ! power for each tb + !IF (windfarm_model == 3) THEN ! GM model + !! YL: For multi-grid cases, I don't have a solution for actual power by GM. + !! It might be scale with the maximun power for the wind farm. + ! IF (blockfrac(kt) == 0.) THEN + ! power_GM = 1. + ! ELSE + ! power_GM = 0.6824 - 0.3405*blockfrac(kt) + 0.2131*blockdist(kt) + ! ENDIF + !ENDIF + + nv = nval(kt) + call dragcof(tkecof, powcof, thrcof, & + ulocal(kt), turbws(kt,1:nv), turbtc(kt,1:nv), & + turbpwcof(kt,1:nv), stc(kt), stc2(kt), nv) + + power1 = 0.5*1.23*ulocal(kt)**3*area(kt)*powcof ! 1.23 density + + power_nt(kt) = power_nt(kt) + power1*dtheta_avg_cof_i + !!------- end power for each tb -------- + + + !----------- WRF tendencies ------------ + ! only considering turbines in the current tile + ! the follwoing code is based on Fitch parameterization + + i = ival(kt) + j = jval(kt) + if (i > itf .or. i < its .or. j > jtf .or. j < jts ) cycle + + ! vertical layers cut by turbine blades + blade_l_point = hubheight(kt) - radius(kt) + blade_u_point = hubheight(kt) + radius(kt) + k_turbine_bot = 0 !bottom level + k_turbine_top = -1 !top level + z_tmp = z_at_w(i,:,j) - z_at_w(i,1,j) + do k = kms, kme-1 + if (blade_l_point >= z_tmp(k) .and. blade_l_point < z_tmp(k+1)) then + k_turbine_bot = k + end if + if (blade_u_point >= z_tmp(k) .and. blade_u_point < z_tmp(k+1)) then + k_turbine_top = k + end if + end do + + ! adjust coef. according to disk averaged power + power2_z(:) = 0. + do k = k_turbine_bot, k_turbine_top ! loop over turbine blade levels + z1 = max(z_tmp(k) - blade_l_point, 0.) + z2 = min(z_tmp(k+1) - blade_l_point, diameter(kt)) + CALL turbine_area(z1, z2, diameter(kt), tarea_z(k)) + + speed_z(k) = ulocal(kt)/Uinf(kt)*sqrt(u(i,k,j)**2 + v(i,k,j)**2) + power2_z(k) = 0.5*1.23*speed_z(k)**3*tarea_z(k)*powcof + end do + power2 = sum(power2_z) + if (power1 == 0. .or. power2 == 0.) then + ec = 1. + else + ec = power1/power2 + end if + !ec = ec*wfdensity + ec = ec*wfdensity*dtheta_avg_cof_i + + power(i,j) = power(i,j) + power2*dtheta_avg_cof_i ! WRF output + + do k = k_turbine_bot, k_turbine_top ! loop over turbine blade levels + !qke_wk(i,k,j) = qke_wk(i,k,j) + speed_z(k)**3*tarea_z(k)*tkecof*dt/dz(i,k,j)*ec + tke_wk(i,k,j) = tke_wk(i,k,j) + 0.5*speed_z(k)**3*tkecof*tarea_z(k)/dz(i,k,j)*dt*ec + du_wk(i,k,j) = du_wk(i,k,j) - 0.5*u(i,k,j)*thrcof*speed_z(k)*tarea_z(k)/dz(i,k,j)*ec + dv_wk(i,k,j) = dv_wk(i,k,j) - 0.5*v(i,k,j)*thrcof*speed_z(k)*tarea_z(k)/dz(i,k,j)*ec + end do + + end do + + end subroutine cal_power_wrf_tend + +!--------------------------------------------------------------- + + subroutine sort_turb(nt, num_ups, ups_index, tbindx) + implicit none + integer, intent(in) :: nt + integer, intent(in) :: num_ups(nt), ups_index(nt,nt) + integer, intent(inout) :: tbindx(nt) + integer :: ic_tb, indx, kt, tt, flag(nt) + + flag(:) = 0 + ic_tb = 0 + + do kt = 1, nt + if (num_ups(kt) == 0) then + ic_tb = ic_tb + 1 + flag(kt) = 1 + tbindx(ic_tb) = kt ! sorted turb starting from upstream + end if + end do + + do while (ic_tb < nt) + do kt = 1, nt + if (flag(kt) == 1) cycle + + do tt = 1, num_ups(kt) + indx = ups_index(kt,tt) + if (flag(indx) == 0) exit + + if (tt == num_ups(kt)) then + ic_tb = ic_tb + 1 + flag(kt) = 1 + tbindx(ic_tb) = kt + end if + end do + end do + enddo + + if (sum(flag) < nt) then + write(*,*) 'something wrong in sorting turbine, wind_jensen/sort_turb' + write(*,*) tbindx + stop + end if + + endsubroutine sort_turb + +!--------------------------------------------------------------- + + subroutine sort_gm(nturb, tbindx, ax_dist) + implicit none + integer, intent(in) :: nturb + integer, intent(out), dimension(nturb) :: tbindx + real, intent(inout), dimension(nturb) :: ax_dist + real, dimension(nturb) :: xloc + integer :: i, a(1) + real :: xmin + integer :: tbindx_cp(nturb) + + xloc = ax_dist + tbindx_cp = tbindx + xmin = minval(xloc) - 1. + + do i = 1, nturb + a = maxloc(xloc) + tbindx(i) = tbindx_cp(a(1)) + xloc(a(1)) = xmin + end do + + end subroutine sort_gm + +!--------------------------------------------------------------- + +!--------------------------------------------------------------- + + subroutine gm_BD_BR_analytical(blockfrac, blockdist, rblockdist, & + radius, num_ups, ups_index, nt, it, ax_dist, y) + implicit none + integer :: nt, num_ups, it + integer :: ups_index(nt) + real :: ax_dist(nt), y(nt) + real :: scaled_axdist(nt), raxdist(nt) + real :: radius + real, intent(out) :: blockfrac, blockdist, rblockdist + + real, parameter :: MAXD = 20. ! upsteam within 20d + integer, parameter :: ndisk = 80 + real :: diameter, radius2, d, BR, BD, mindr, mindl + integer :: tt, jt, numuptl, numuptr, jmindisl, jmindisr + real :: blockdist_ups(nt), blockfrac_ups(nt), rblockdist_ups(nt) + + if (num_ups == 0) then + blockfrac = 0. + return + endif + + diameter = radius*2 + radius2 = radius**2 + + blockfrac_ups(:) = 0. + blockdist_ups(:) = 0. + rblockdist_ups(:) = 0. + + mindr = diameter + mindl = diameter + numuptl = 0 + numuptr = 0 + jmindisl = 0 + jmindisr = 0 + + ! only look for 4 upstream turbines ??? YL + + do tt = num_ups, 1, -1 ! starting from the closest turbine + jt = ups_index(tt) + if (ax_dist(jt) > maxd*diameter) exit ! only consider ups tbs within 20d + + !-------------------- + d = y(jt) - y(it) + + if (d <= 0.) then !upstream turbine on the left side of (or on) the centerline + numuptl = numuptl + 1 + if (abs(d) > mindl) then + blockfrac_ups(jt) = 0. + else + if (numuptl == 1) then + if (numuptr == 0) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + else + if ( abs(d) + mindr < diameter ) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(jt), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + end if + end if + else + if (numuptr > 0 .and. abs(d) + mindr < diameter) then + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) - & + Ao_GM(y(jt), y(jmindisr), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) - & + Ao_GM(y(jt), y(jmindisr), radius) + end if + else + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisl), radius) + end if + end if + end if + mindl = abs(d) + jmindisl = jt + + ! don't need to look for further ups tbs + if (d == 0.) then + blockdist_ups(jt) = blockfrac_ups(jt)*ax_dist(jt)/(MAXD*diameter) + rblockdist_ups(jt) = blockfrac_ups(jt)/ax_dist(jt) + exit + end if + + end if + + else !upstream turbine on the right side of the centerline + numuptr = numuptr + 1 + if (abs(d) > mindr) then + blockfrac_ups(jt) = 0. + else + if (numuptr == 1) then + if (numuptl == 0) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + else + if ( abs(d) + mindl < diameter ) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(jt), y(jmindisl), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) + end if + end if + else + if (numuptl > 0 .and. abs(d) + mindl < diameter) then + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) - & + Ao_GM(y(jt), y(jmindisl), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) - & + Ao_GM(y(jt), y(jmindisl), radius) + end if + else + if (mindr + mindl < diameter) then + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) + & + Ao_GM(y(jmindisl), y(jmindisr), radius) + else + blockfrac_ups(jt) = Ao_GM(y(it), y(jt), radius) - & + Ao_GM(y(it), y(jmindisr), radius) + end if + end if + end if + mindr = abs(d) + jmindisr = jt + end if + end if !center, left and right are all done for blockfrac_ups(jt) + + blockdist_ups(jt) = blockfrac_ups(jt)*ax_dist(jt)/(MAXD*diameter) + rblockdist_ups(jt) = blockfrac_ups(jt)/ax_dist(jt) + + end do + + BR = sum(blockfrac_ups) + BD = sum(blockdist_ups) + 1.*(1.-BR) ! normalized dist for non-blocked part is 1. + + blockfrac = BR + blockdist = BD + rblockdist = sum(rblockdist_ups) + + if (blockdist > 1.) blockfrac = 0. + + end subroutine gm_BD_BR_analytical + +!--------------------------------------------------------------- + + function Ao_GM(x1, x2, Radius) result(Ao) + implicit none + real,intent(in) :: x1,x2,Radius + real :: Ao + real :: d, l, theta, Asector, Atriangle + + Ao = 0. + d = sqrt((x1-x2)**2) + if (d<2*Radius) then + l = d/2. !Improve later in case hubs are not at same height + theta = 2 * acos(l/Radius) + Asector = theta/2.*Radius**2 + Atriangle = l*Radius*sin(theta/2.) + Ao = 2*(Asector - Atriangle)/(piconst*radius**2) + end if + + end function Ao_GM + +!--------------------------------------------------------------- + + function AreaOverlap(y1, y2, z1, z2, r1, r2) result(AOverlap) + implicit none + real,intent(in) :: y1, y2, z1, z2, r1, r2 + real :: AOverlap + real :: c, CBD, CAD + + c = sqrt((z1-z2)**2 + (y1-y2)**2) + + if ((c + min(r2,r1)) <= max(r2,r1)) then + AOverlap = piconst*min(r2,r1)**2 + else if ((r1 + r2) <= c) then + AOverlap = 0. + else + CBD = acos((r2**2 + c**2 - r1**2)/(2*r2*c)) + CAD = acos((r1**2 + c**2 - r2**2)/(2*r1*c)) + AOverlap = CBD*r2**2 + CAD*r1**2 - 0.5*r2**2*sin(2*CBD) - 0.5*r1**2*sin(2*CAD) + !AOverlap = CBD*r2**2 + CAD*r1**2 - r1*c*sin(CAD) + end if + + end function AreaOverlap + +!--------------------------------------------------------------- + + function find_turb(xc, yc, xt, yt, u, v, sr_angle, sr_dis) result(ft) + implicit none + logical :: ft + real :: xc, yc, xt, yt, sr_angle, sr_dis, u, v + real :: posi_angle, posi_dis, spd, xp, yp, angle + real ( kind = 8 ) :: tmp1, tmp2 + + ft = .false. + + xp = xt - xc + yp = yt - yc + posi_dis = sqrt(yp**2 + xp**2) + + if (posi_dis <= sr_dis) then + posi_angle = atan2(-yp, -xp) + spd = sqrt(u**2 + v**2) + !tmp1 = -(u*xp + v*yp) ! negative means ups diretion + tmp1 = real( -(u*xp + v*yp), kind = 8 ) + tmp2 = real( sqrt( (u**2 + v**2) * (xp**2 + yp**2) ), kind = 8) + + if (abs(tmp2) < abs(tmp1)) then + tmp2 = sign(tmp1,tmp2) + end if + + angle = real(acos(tmp1/tmp2), kind = 4) + + if (isnan(angle)) then + angle = 0. + end if + + if (abs(angle) <= sr_angle) then + ft = .true. + end if + end if + + end function find_turb + +!--------------------------------------------------------------- + + subroutine coordinate_rotation(xr, yr, x, y, theta) + implicit none + real :: xr, yr, x, y, theta + xr = x*cos(theta) + y*sin(theta) + yr = -x*sin(theta) + y*cos(theta) + end subroutine coordinate_rotation + +!--------------------------------------------------------------- + + subroutine Gaussian_integral(ch, ck, R, sigma_x, sigma_y, avg_val) + ! integration of Gaussian distribution over an offset circle: + ! (x-ch)**2 + (y-ck)**2 <= R**2 + ! DiDonato and Jarnagin, 1961 + implicit none + real, intent(in) :: ch, ck, R, sigma_x, sigma_y + real :: d01, d11, t, A, P, avg_val, sum_val + real :: WW(24), XX(24) ! 24 point gaussian quadrature integral for 1D function + integer :: i + + ! https://pomax.github.io/bezierinfo/legendre-gauss.html + WW( 1)=0.1279381953467522; XX( 1)= -0.0640568928626056 + WW( 2)=0.1279381953467522; XX( 2)= 0.0640568928626056 + WW( 3)=0.1258374563468283; XX( 3)= -0.1911188674736163 + WW( 4)=0.1258374563468283; XX( 4)= 0.1911188674736163 + WW( 5)=0.1216704729278034; XX( 5)= -0.3150426796961634 + WW( 6)=0.1216704729278034; XX( 6)= 0.3150426796961634 + WW( 7)=0.1155056680537256; XX( 7)= -0.4337935076260451 + WW( 8)=0.1155056680537256; XX( 8)= 0.4337935076260451 + WW( 9)=0.1074442701159656; XX( 9)= -0.5454214713888396 + WW(10)=0.1074442701159656; XX(10)= 0.5454214713888396 + WW(11)=0.0976186521041139; XX(11)= -0.6480936519369755 + WW(12)=0.0976186521041139; XX(12)= 0.6480936519369755 + WW(13)=0.0861901615319533; XX(13)= -0.7401241915785544 + WW(14)=0.0861901615319533; XX(14)= 0.7401241915785544 + WW(15)=0.0733464814110803; XX(15)= -0.8200019859739029 + WW(16)=0.0733464814110803; XX(16)= 0.8200019859739029 + WW(17)=0.0592985849154368; XX(17)= -0.8864155270044011 + WW(18)=0.0592985849154368; XX(18)= 0.8864155270044011 + WW(19)=0.0442774388174198; XX(19)= -0.9382745520027328 + WW(20)=0.0442774388174198; XX(20)= 0.9382745520027328 + WW(21)=0.0285313886289337; XX(21)= -0.9747285559713095 + WW(22)=0.0285313886289337; XX(22)= 0.9747285559713095 + WW(23)=0.0123412297999872; XX(23)= -0.9951872199970213 + WW(24)=0.0123412297999872; XX(24)= 0.9951872199970213 + + sum_val = 0. + do i = 1, 24 ! 24 point gaussian quadrature integral + t = 0.5*XX(i) + 0.5 + d01 = (ck - R*t*sqrt(2.-t**2))/(sqrt(2.)*sigma_y) + d11 = (ck + R*t*sqrt(2.-t**2))/(sqrt(2.)*sigma_y) + P = (exp(-0.5*( (ch - R*(1.-t**2))/sigma_x )**2) + & + exp(-0.5*( (ch + R*(1.-t**2))/sigma_x )**2)) * & + (erf(d11) - erf(d01))*t + sum_val = sum_val + 0.5*WW(i)*P + end do + !A = R/sigma_y/np.sqrt(2*np.pi) ! normalized gaussian distribution + A = (2*piconst*sigma_x*sigma_y) * R/sigma_x/sqrt(2*piconst) + avg_val = A*sum_val/(piconst*R**2) + + end subroutine Gaussian_integral + +!--------------------------------------------------------------- + + subroutine to_zk2(obs_v, mdl_v, mdl_data, iz, interp_out ) + ! 1D interp function + implicit none + integer :: k, iz, k1 + real, intent(in) :: obs_v + real, dimension(1:iz), intent(in) :: mdl_v, mdl_data + real, intent(out) :: interp_out + real :: dz, dzm, zk + + if (obs_v < mdl_v(1) ) then + interp_out = mdl_data(1) + return + else if (obs_v >= mdl_v(iz)) then + interp_out = mdl_data(iz) + return + else + do k = 1,iz-1 + if(obs_v >= mdl_v(k) .and. obs_v < mdl_v(k+1)) then + zk = real(k) + (obs_v - mdl_v(k))/(mdl_v(k+1) - mdl_v(k)) + exit + end if + end do + k1 = int( zk ) + dz = zk - float( k1 ) + dzm = float( k1+1 ) - zk + + interp_out = dzm*mdl_data(k1) + dz*mdl_data(k1+1) + return + end if + + end subroutine to_zk2 + +!--------------------------------------------------------------- + + subroutine turbine_area(z1, z2, tdiameter, tarea) + ! This subroutine calculates area of turbine between two vertical levels + ! Input variables : + ! z1 = distance between k level and lower blade tip + ! z2 = distance between k+1 level and lower blade tip + ! wfdensity = wind farm density in m^-2 + ! tdiameter = turbine diameter + ! Output variable : + ! tarea = area of turbine between two levels + implicit none + real, intent(in) :: tdiameter + real, intent(inout) :: z1, z2 + real, intent(out):: tarea + real r, zc1, zc2 + + r = 0.5*tdiameter !r = turbine radius + z1 = r - z1 !distance of kth level from turbine center + z2 = r - z2 !distance of k+1 th level from turbine center + zc1 = abs(z1) + zc2 = abs(z2) + + ! turbine area between z1 and z2 + if(z1 > 0. .and. z2 > 0.) then + tarea = zc1*sqrt(r*r - zc1*zc1) + r*r*asin(zc1/r) - & + zc2*sqrt(r*r - zc2*zc2) - r*r*asin(zc2/r) + else if(z1 < 0. .and. z2 < 0.) then + tarea = zc2*sqrt(r*r - zc2*zc2) + r*r*asin(zc2/r) - & + zc1*sqrt(r*r - zc1*zc1) - r*r*asin(zc1/r) + else + tarea = zc2*sqrt(r*r - zc2*zc2) + r*r*asin(zc2/r) + & + zc1*sqrt(r*r - zc1*zc1) + r*r*asin(zc1/r) + end if + + end subroutine turbine_area + +!--------------------------------------------------------------- + + subroutine dragcof(tkecof, powcof, thrcof, speed, & + turb_ws, turb_tc, turb_pwcof, stdthrcoef, stdthrcoef2, nv) + implicit none + real, intent(in):: speed, stdthrcoef, stdthrcoef2 + integer :: nv + real, dimension(1:nv) :: turb_ws, turb_tc, turb_pwcof + real, intent(out):: tkecof,powcof,thrcof + real :: cispeed, cospeed + + cispeed = turb_ws(1) + cospeed = turb_ws(nv) + + if (speed < cispeed) then + thrcof = stdthrcoef + powcof = 0. + else if (speed > cospeed) then + thrcof = stdthrcoef2 + powcof = 0. + else + call to_zk2(speed, turb_ws(1:nv), turb_tc(1:nv), nv, thrcof) + call to_zk2(speed, turb_ws(1:nv), turb_pwcof(1:nv), nv, powcof) + endif + + ! tke coefficient calculation + tkecof = max(0., thrcof-powcof) !Cri: consider multiplying by 0.5 or so + tkecof = correction_factor * tkecof + !tkecof = 0.25*tkecof ! Yulong + + end subroutine dragcof + +!--------------------------------------------------------------- + +#if defined(mpas) + SUBROUTINE point_in_polyogon(find, px, py, xcell, ycell, dv) + implicit none + + ! dv: side length of hexgon + real, intent(in) :: px, py, xcell, ycell, dv + real :: xx, yy + logical :: find + + xx = abs(px - xcell) + yy = abs(py - ycell) + + find = .false. + if (xx <= dv .and. yy <= sqrt(3.)/2.*dv) then ! in the outer rectangle + if (dv - xx >= yy/sqrt(3.) ) find = .true. + endif + + END SUBROUTINE point_in_polyogon + +!--------------------------------------------------------------- + + ! called in core_atmosphere/physics/mpas_atmphys_init.F + subroutine init_module_wind_jensen_MPAS(dminfo, windfarm_ij, windfarm_deg, & + xcell, ycell, ncells, dc) + implicit none + type(dm_info),intent(in) :: dminfo + integer :: ncells + integer, parameter :: id = 1 + integer :: windfarm_ij + real :: windfarm_deg + real :: dc, dv + real, dimension(ncells), intent(in) :: xcell, ycell !hexgon cell center +! + real :: lat,lon,ts_rx,ts_ry + real :: known_lat, known_lon + integer :: i,j,k,ios, igs, jgs + + real :: x_rot, y_rot, theta, deg, xtb_center, ytb_center, xp, yp + logical :: find + character*256 num,input + + if (windfarm_initialized) return + + windfarm_initialized = .true. + + dv = sqrt(3.)/3.*dc + + if (windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + else if (windfarm_ij == 2) then + open(71,file='windturbines-ll.txt',form='formatted',status='old',iostat=ios) + end if + + nt = 0 + do + read(71, *, iostat=ios) + if (ios /= 0) exit + nt = nt + 1 + end do + close(71) + + allocate (nkind(nt),nval(nt),ival(nt,max_domains),jval(nt,max_domains)) + allocate (xturb(nt,max_domains),yturb(nt,max_domains)) + allocate (hubheight(nt),stc(nt),stc2(nt),area(nt),radius(nt),radius2(nt),diameter(nt),npower(nt)) + allocate(turbws(nt,MAXVALS),turbtc(nt,MAXVALS),turbpw(nt,MAXVALS),turbpwcof(nt,MAXVALS)) + + xturb = -9999. + yturb = -9999. + ival = -9999 + jval = -9999 + turbws = 0. + turbtc = 0. + turbpw = 0. + turbpwcof = 0. + + if (windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + do k = 1, nt + nkind(k) = 1 + read(71,*) xturb(k,id), yturb(k,id) + enddo + close(71) + + !------- set wind farm center coordinate to (0,0) --- + xtb_center = sum(xturb(1:nt,id))/nt + ytb_center = sum(yturb(1:nt,id))/nt + do k = 1, nt + xturb(k,id) = xturb(k,id) - xtb_center + yturb(k,id) = yturb(k,id) - ytb_center + end do + !----------------------------------------------------- + + !------- rotate wind farm ------- + deg = windfarm_deg + do k = 1, nt + !theta = -30./180.*piconst ! d255: 225 - 255 = -30 + + theta = deg/180.*piconst + call coordinate_rotation(x_rot, y_rot, xturb(k,id), yturb(k,id), theta) + xturb(k,id) = x_rot + yturb(k,id) = y_rot + end do + !------------------------------- + + !!-------------- find ix, iy ----------------- + + igs = 10 + jgs = 12 + ival(:,id) = -9999 + jval(:,id) = 1 + DO k = 1, nt + xp = xturb(k,id) + igs*sqrt(3.)/2.*dc + yp = yturb(k,id) + jgs*sqrt(3.)/2.*dc + DO i = 1, ncells + call point_in_polyogon(find, xp, yp, xcell(i), ycell(i), dv) + IF (find) THEN + ival(k,id) = i + EXIT + ENDIF + ENDDO + ENDDO + + !write(*,*) 'MPAS loc0:', ival(:,id) + !call mpas_dmpar_bcast_ints(dminfo, nt, ival(:,id)) + + ! ---- test in one cell --- + !ival(:,id) = ival(1,id) + !write(*,*) 'MPAS loc:', ival(1,id) + write(*,*) 'MPAS loc:' + do k = 1, nt + write(*,*) k, ival(k,id) + end do + !write(*,*) 'xcell:', xcell(1), xcell(ncells) + !write(*,*) 'ycell:', ycell(1), ycell(ncells) + ! ---- test in one cell --- + !!-------------- end find ix, iy ----------- + + do k = 1, nt + write(num,*) nkind(k) + num = adjustl(num) + input = "wind-turbine-"//trim(num)//".tbl" + open(file=trim(input),unit=19,form='formatted',status='old') + read(19,*) nval(k) + read(19,*) hubheight(k), diameter(k), stc(k), npower(k) + + area(k)=piconst/4.*diameter(k)**2 + + do i = 1, nval(k) + read(19,*) turbws(k,i), turbtc(k,i), turbpw(k,i) + turbpwcof(k,i) = turbpw(k,i)*1000./(0.5*1.23*turbws(k,i)**3*area(k)) + end do + + radius(k) = 0.5*diameter(k) + radius2(k) = radius(k)**2 + stc2(k) = turbtc(k,nval(k)) + close (19) + end do + endif + + end subroutine init_module_wind_jensen_MPAS + +!--------------------------------------------------------------- +#else + +subroutine cal_xturb_yturb(lat_nt, lon_nt, wf_id_nt, nt, xturb_nt, yturb_nt) + implicit none + integer :: nt + real(kind=8) :: lat_nt(nt), lon_nt(nt) + integer :: wf_id_nt(nt) + real(kind=8) :: xturb_nt(nt), yturb_nt(nt) + + integer :: ic, wf_id, k, kk, ik, mid_ic, nn + real(kind=8) :: lon_tmp(nt), lat_wf(nt), lon_wf(nt) + real(kind=8) :: lon_center, x, y + real(kind=8) :: x_center, y_center + real(kind=8) :: off_dist = 600000. ! used to seprate wind farms + integer :: num_wf + + num_wf = 1 + + ik = 1 + ic = 1 + wf_id = wf_id_nt(1) + lon_tmp(ic) = lon_nt(1) + lat_wf(ic) = lat_nt(1) + lon_wf(ic) = lon_nt(1) + do k = 2, nt + if (wf_id_nt(k) == wf_id) then + ic = ic + 1 + lon_tmp(ic) = lon_nt(k) + lat_wf(ic) = lat_nt(k) + lon_wf(ic) = lon_nt(k) + else if (wf_id_nt(k) /= wf_id) then + call shell_sort_1D(lon_tmp(1:ic),ic) + mid_ic = ceiling(ic*0.5) + lon_center = lon_tmp(mid_ic) + + x_center = 0. + y_center = 0. + do kk = 1, ic + call latlon_to_xy(lat_wf(kk), lon_wf(kk), lon_center, x, y) + !call latlon_to_xy(lat_wf(kk), lon_wf(kk), real(9.,kind=8), x, y) !Anholt test + xturb_nt(ik) = x + yturb_nt(ik) = y + x_center = x_center + x + y_center = y_center + y + ik = ik + 1 + enddo + + x_center = x_center/ic + y_center = y_center/ic + do kk = ik-ic, ik-1 + xturb_nt(kk) = xturb_nt(kk) - x_center + yturb_nt(kk) = yturb_nt(kk) - y_center + num_wf*off_dist! off set distance for wind farm [m] + enddo + + num_wf = num_wf + 1 + ic = 1 + wf_id = wf_id_nt(k) + lon_tmp(ic) = lon_nt(k) + lat_wf(ic) = lat_nt(k) + lon_wf(ic) = lon_nt(k) + endif + enddo + + call shell_sort_1D(lon_tmp(1:ic),ic) + mid_ic = ceiling(ic*0.5) + lon_center = lon_tmp(mid_ic) + + x_center = 0. + y_center = 0. + do kk = 1, ic + call latlon_to_xy(lat_wf(kk), lon_wf(kk), lon_center, x, y) + !call latlon_to_xy(lat_wf(kk), lon_wf(kk), real(9.,kind=8), x, y) !Anholt test + xturb_nt(ik) = x + yturb_nt(ik) = y + x_center = x_center + x + y_center = y_center + y + ik = ik + 1 + enddo + + x_center = x_center/ic + y_center = y_center/ic + do kk = ik-ic, ik-1 + xturb_nt(kk) = xturb_nt(kk) - x_center + yturb_nt(kk) = yturb_nt(kk) - y_center + num_wf*off_dist ! off set distance for wind farm [m] + enddo + +end subroutine cal_xturb_yturb + +!------------------------------ + +subroutine latlon_to_xy(latitude, longitude, central_lon, easting, northing) +! from https://github.com/Turbo87/utm/blob/master/utm/conversion.py + implicit none + real(kind=8), intent(in) :: latitude, longitude, central_lon + real(kind=8), intent(out) :: easting, northing + + real(kind=8), PARAMETER :: pi = 3.141592653589793 + real(kind=8) :: lat_rad, lat_sin, lat_cos, lat_tan, lat_tan2, lat_tan4 + real(kind=8) :: lon_rad + real(kind=8) :: central_lon_rad, dlon_rad + + real(kind=8), PARAMETER :: K0 = 0.9996 + real(kind=8), PARAMETER :: E = 0.00669438 + real(kind=8), PARAMETER :: R = 6378137. + real(kind=8) :: E2, E3, E_P2, SQRT_E + real(kind=8) :: XE, XE2, XE3, XE4, XE5 + real(kind=8) :: M1, M2, M3, M4, P2, P3, P4, P5 + real(kind=8) :: n, c, a, a2, a3, a4, a5, a6, m + + lat_rad = latitude*pi/180. + lat_sin = sin(lat_rad) + lat_cos = cos(lat_rad) + + lat_tan = lat_sin / lat_cos + lat_tan2 = lat_tan * lat_tan + lat_tan4 = lat_tan2 * lat_tan2 + + lon_rad = longitude*pi/180. + + ! differenct from UTM, set center lon at the wind farm center + central_lon_rad = central_lon*pi/180. + + ! -pi to pi + dlon_rad = mod(lon_rad - central_lon_rad + pi, 2*pi) - pi + + E2 = E * E + E3 = E2 * E + E_P2 = E / (1. - E) + + SQRT_E = sqrt(1. - E) + + XE = (1. - SQRT_E) / (1. + SQRT_E) + XE2 = XE * XE + XE3 = XE2 * XE + XE4 = XE3 * XE + XE5 = XE4 * XE + + M1 = (1. - E / 4. - 3. * E2 / 64. - 5. * E3 / 256.) + M2 = (3. * E / 8. + 3. * E2 / 32. + 45. * E3 / 1024.) + M3 = (15. * E2 / 256. + 45. * E3 / 1024.) + M4 = (35. * E3 / 3072.) + + P2 = (3. / 2. * XE - 27. / 32. * XE3 + 269. / 512. * XE5) + P3 = (21. / 16. * XE2 - 55. / 32. * XE4) + P4 = (151. / 96. * XE3 - 417. / 128. * XE5) + P5 = (1097. / 512. * XE4) + + + n = R / sqrt(1. - E * lat_sin**2) + c = E_P2 * lat_cos**2 + + a = lat_cos * dlon_rad + a2 = a * a + a3 = a2 * a + a4 = a3 * a + a5 = a4 * a + a6 = a5 * a + + m = R * (M1 * lat_rad - & + M2 * sin(2. * lat_rad) + & + M3 * sin(4. * lat_rad) - & + M4 * sin(6. * lat_rad)) + + easting = K0 * n * (a + & + a3 / 6. * (1. - lat_tan2 + c) + & + a5 / 120. * (5. - 18. * lat_tan2 + lat_tan4 + 72. * c - 58. * E_P2)) + 500000. + + northing = K0 * (m + n * lat_tan * & + (a2 / 2. + & + a4 / 24. * (5. - lat_tan2 + 9. * c + 4. * c**2) + & + a6 / 720. * (61. - 58. * lat_tan2 + lat_tan4 + 600. * c - 330. * E_P2))) + +! if (latitude < 0.) northing = northing + 10000000. + +end subroutine latlon_to_xy + +!------------------------------ + +subroutine shell_sort_1D(AA, n) + implicit none + integer :: n, k + real(kind=8), dimension(1:n) :: AA + integer :: i,j + real(kind=8) :: A_tmp + integer :: B_tmp + k=n/2 + do while( k>0 ) + do i=k+1,n + j=i-k + do while( j>0 ) + if ( AA(j) .gt. AA(j+k) ) then + A_tmp = AA(j) + AA(j) = AA(j+k) + AA(j+k) = A_tmp + + j=j-k + else + exit + end if + end do + end do + k=k/2 + end do + +end subroutine shell_sort_1D + + subroutine init_module_wind_mav(id,config_flags,xlong,xlat,windfarm_initialized,dx,& + ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde) + USE module_date_time ! must within subroutine, module_date_time.F ../share/ + implicit none + integer :: ims,ime,jms,jme,ids,ide,jds,jde + integer :: its,ite,jts,jte + real :: dx + real, dimension(ims:ime, jms:jme), intent(in) :: xlong,xlat + + type (grid_config_rec_type) :: config_flags + type (proj_info) :: ts_proj + logical :: windfarm_initialized ! WRF + character*256 num,input,message_wind + real :: lat,lon,ts_rx,ts_ry + real :: known_lat, known_lon + integer :: i,j,k,id,ios, igs, jgs + + real :: xgrid(ide), ygrid(jde), tmp + real :: x_rot, y_rot, theta, deg, xtb_center, ytb_center + + logical, external :: wrf_dm_on_monitor + + + !--- local --- + real(kind=8), dimension(:), allocatable :: lat_nt, lon_nt, xturb_nt, yturb_nt + integer, dimension(:), allocatable :: wf_id_nt + !--- local --- + + !--------- + logical :: lexist + CHARACTER (LEN=24) :: date_str + INTEGER:: julyr + INTEGER:: julday + REAL :: gmt + real(kind=8) :: calday + + !IF ( windfarm_initialized) RETURN + + correction_factor = config_flags%windfarm_tke_factor + + ! get turbine number nt + if ( wrf_dm_on_monitor() ) then + if (config_flags%windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + else if (config_flags%windfarm_ij == 2) then + open(71,file='windturbines-ll.txt',form='formatted',status='old',iostat=ios) + end if + + nt = 0 + do + read(71, *, iostat=ios) + if (ios /= 0) exit + nt = nt + 1 + end do + close(71) + end if + + call wrf_dm_bcast_integer(nt,1) + + if (.not. windfarm_initialized) then + allocate (nkind(nt),nval(nt),ival(nt,max_domains),jval(nt,max_domains)) + allocate (xturb(nt,max_domains),yturb(nt,max_domains)) + allocate (hubheight(nt),stc(nt),stc2(nt),area(nt),radius(nt),radius2(nt),diameter(nt),npower(nt)) + allocate(turbws(nt,MAXVALS),turbtc(nt,MAXVALS),turbpw(nt,MAXVALS),turbpwcof(nt,MAXVALS)) + + allocate (xturb_nt(nt),yturb_nt(nt)) + allocate (lat_nt(nt),lon_nt(nt)) + allocate (wf_id_nt(nt)) + + turbws = 0. + turbtc = 0. + turbpw = 0. + turbpwcof = 0. + nkind(:) = 1 + + windfarm_initialized = .true. + end if + + if (.not. allocated(nkind)) allocate(nkind(nt)) + if (.not. allocated(nval)) allocate(nval(nt)) + if (.not. allocated(ival)) allocate(ival(nt,max_domains)) + if (.not. allocated(jval)) allocate(jval(nt,max_domains)) + if (.not. allocated(xturb)) allocate(xturb(nt,max_domains)) + if (.not. allocated(yturb)) allocate(yturb(nt,max_domains)) + if (.not. allocated(hubheight)) allocate(hubheight(nt)) + if (.not. allocated(stc)) allocate(stc(nt)) + if (.not. allocated(stc2)) allocate(stc2(nt)) + if (.not. allocated(area)) allocate(area(nt)) + if (.not. allocated(radius)) allocate(radius(nt)) + if (.not. allocated(radius2)) allocate(radius2(nt)) + if (.not. allocated(diameter)) allocate(diameter(nt)) + if (.not. allocated(npower)) allocate(npower(nt)) + if (.not. allocated(turbws)) allocate(turbws(nt,maxvals)) + if (.not. allocated(turbtc)) allocate(turbtc(nt,maxvals)) + if (.not. allocated(turbpw)) allocate(turbpw(nt,maxvals)) + if (.not. allocated(turbpwcof)) allocate(turbpwcof(nt,maxvals)) + + if (.not. allocated(xturb_nt)) allocate(xturb_nt(nt)) + if (.not. allocated(yturb_nt)) allocate(yturb_nt(nt)) + if (.not. allocated(lat_nt)) allocate(lat_nt(nt)) + if (.not. allocated(lon_nt)) allocate(lon_nt(nt)) + if (.not. allocated(wf_id_nt)) allocate(wf_id_nt(nt)) + + xturb(:,id) = -9999. + yturb(:,id) = -9999. + ival(:,id) = -9999 + jval(:,id) = -9999 + + ! + ! --- find turbine location --- + ! + if ( wrf_dm_on_monitor() ) then + + ! real case, based on lat, lon + if (config_flags%windfarm_ij == 2) then + CALL map_init(ts_proj) + open(71,file='windturbines-ll.txt',form='formatted',status='old',iostat=ios) + + do k = 1, nt + !read(71,*) lat, lon + read(71,*) lat_nt(k), lon_nt(k), wf_id_nt(k), nkind(k) + lat = lat_nt(k) + lon = lon_nt(k) + known_lat = xlat(its,jts) + known_lon = xlong(its,jts) + + ! Mercator + if (config_flags%map_proj == PROJ_MERC) then + call map_set(PROJ_MERC, ts_proj, & + truelat1 = config_flags%truelat1, & + lat1 = known_lat, & + lon1 = known_lon, & + knowni = REAL(its), & + knownj = REAL(jts), & + dx = config_flags%dx) + + ! Lambert conformal + else if (config_flags%map_proj == PROJ_LC) then + call map_set(PROJ_LC, ts_proj, & + truelat1 = config_flags%truelat1, & + truelat2 = config_flags%truelat2, & + stdlon = config_flags%stand_lon, & + lat1 = known_lat, & + lon1 = known_lon, & + knowni = REAL(its), & + knownj = REAL(jts), & + dx = config_flags%dx) + + ! Polar stereographic + else if (config_flags%map_proj == PROJ_PS) then + call map_set(PROJ_PS, ts_proj, & + truelat1 = config_flags%truelat1, & + stdlon = config_flags%stand_lon, & + lat1 = known_lat, & + lon1 = known_lon, & + knowni = REAL(its), & + knownj = REAL(jts), & + dx = config_flags%dx) + end if + + call latlon_to_ij(ts_proj, lat, lon, ts_rx, ts_ry) + + ival(k,id)=nint(ts_rx) + jval(k,id)=nint(ts_ry) +! write(*,*) 'sss', id, k, ts_rx + if (ival(k,id).lt.ids.and.ival(k,id).gt.ide) then + ival(k,id) = -9999 + jval(k,id) = -9999 + end if + + end do + close(71) + + !--- cal turbine locations (x,y in [m]) based on (lat, lon) + call cal_xturb_yturb(lat_nt, lon_nt, wf_id_nt, nt, xturb_nt, yturb_nt) + do k = 1, nt + xturb(k,id) = xturb_nt(k) + yturb(k,id) = yturb_nt(k) + !write(*,*) xturb(k,id), yturb(k,id) + end do + + end if ! windfarm_ij == 2 + + ! ideal case, based on x, y (m) + if (config_flags%windfarm_ij == 1) then + open(71,file='windturbines-xy.txt',form='formatted',status='old',iostat=ios) + do k = 1, nt + read(71,*) xturb(k,id), yturb(k,id), wf_id_nt(k), nkind(k) + !read(71,*) xturb(k,id), yturb(k,id) + ! wf_id_nt(k) = 1 + ! nkind(k) = 1 + enddo + close(71) + + ! reset wind farm center coordinate to (0,0) + xtb_center = sum(xturb(1:nt,id))/nt + ytb_center = sum(yturb(1:nt,id))/nt + do k = 1, nt + xturb(k,id) = xturb(k,id) - xtb_center + yturb(k,id) = yturb(k,id) - ytb_center + end do + + ! rotate wind farm + deg = config_flags%windfarm_deg + do k = 1, nt + !theta = -30./180.*piconst ! d255: 225 - 255 = -30 + theta = deg/180.*piconst + call coordinate_rotation(x_rot, y_rot, xturb(k,id), yturb(k,id), theta) + xturb(k,id) = x_rot + yturb(k,id) = y_rot + end do + + !!-------------- find ix, iy ----------------- + !igs = int(ide/2.5); jgs = int(jde/2.5) ! set wind farm center grid + igs = int(ide/3); jgs = int(jde/3) ! set wind farm right lower coner + + do i = 1, ide + xgrid(i) = (i-1)*dx + end do + do j = 1, jde + ygrid(j) = (j-1)*dx + end do + + do k = 1, nt + tmp = (igs-1)*dx + xturb(k,id) + do i = 1, ide-1 + if (xgrid(i) <= tmp .and. xgrid(i+1) > tmp) then + ival(k,id) = i + exit + end if + end do + + tmp = (jgs-1)*dx + yturb(k,id) + do j = 1, jde-1 + if (ygrid(j) <= tmp .and. ygrid(j+1) > tmp) then + jval(k,id) = j + exit + end if + end do + + ! ---- test in one cell --- + !ival(k,id) = igs + !jval(k,id) = jgs + !ival(k,id) = 12 + !jval(k,id) = 12 + ! ---- test in one cell --- + end do + !!-------------- end find ix, iy ----------- + write(*,*) 'WRF loc:' + do k = 1, nt + write(*,*) k, ival(k,id), jval(k,id) + end do + end if + end if + + ! + ! read turbine info + ! + if ( wrf_dm_on_monitor() ) then + do k = 1, nt + write(num,*) nkind(k) + num = adjustl(num) + input = "wind-turbine-"//trim(num)//".tbl" + open(file=trim(input),unit=19,form='formatted',status='old') + read(19,*) nval(k) + read(19,*) hubheight(k), diameter(k), stc(k), npower(k) + + area(k)=piconst/4.*diameter(k)**2 + + do i = 1, nval(k) + read(19,*) turbws(k,i), turbtc(k,i), turbpw(k,i) + turbpwcof(k,i) = turbpw(k,i)*1000./(0.5*1.23*turbws(k,i)**3*area(k)) + end do + + radius(k) = 0.5*diameter(k) + radius2(k) = radius(k)**2 + stc2(k) = turbtc(k,nval(k)) + close (19) + end do + end if + + call wrf_dm_bcast_integer(nval,nt) + call wrf_dm_bcast_integer(ival,nt*max_domains) + call wrf_dm_bcast_integer(jval,nt*max_domains) + call wrf_dm_bcast_real(xturb,nt*max_domains) + call wrf_dm_bcast_real(yturb,nt*max_domains) + call wrf_dm_bcast_real(hubheight,nt) + call wrf_dm_bcast_real(area,nt) + call wrf_dm_bcast_real(radius,nt) + call wrf_dm_bcast_real(radius2,nt) + call wrf_dm_bcast_real(diameter,nt) + call wrf_dm_bcast_real(stc,nt) + call wrf_dm_bcast_real(stc2,nt) + call wrf_dm_bcast_real(npower,nt) + call wrf_dm_bcast_integer(nkind,nt) + call wrf_dm_bcast_real(turbws,nt*maxvals) + call wrf_dm_bcast_real(turbtc,nt*maxvals) + call wrf_dm_bcast_real(turbpw,nt*maxvals) + call wrf_dm_bcast_real(turbpwcof,nt*maxvals) + + end subroutine init_module_wind_mav + +#endif +END MODULE module_wind_mav diff --git a/phys/physics_mmm/bl_gwdo.F90 b/phys/physics_mmm/bl_gwdo.F90 new file mode 100644 index 0000000000..b314634539 --- /dev/null +++ b/phys/physics_mmm/bl_gwdo.F90 @@ -0,0 +1,649 @@ +!================================================================================================================= + module bl_gwdo + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: bl_gwdo_run, & + bl_gwdo_init, & + bl_gwdo_finalize + + + contains + + +!================================================================================================================= +!>\section arg_table_bl_gwdo_init +!!\html\include bl_gwdo_init.html +!! + subroutine bl_gwdo_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_gwdo_init OK' + errflg = 0 + + end subroutine bl_gwdo_init + +!================================================================================================================= +!>\section arg_table_bl_gwdo_finalize +!!\html\include bl_gwdo_finalize.html +!! + subroutine bl_gwdo_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_gwdo_finalize OK' + errflg = 0 + + end subroutine bl_gwdo_finalize + +!================================================================================================================= +!>\section arg_table_bl_gwdo_run +!!\html\include bl_gwdo_run.html +!! + subroutine bl_gwdo_run(sina, cosa, & + rublten,rvblten, & + dtaux3d,dtauy3d, & + dusfcg,dvsfcg, & + uproj, vproj, & + t1, q1, & + prsi, prsl, prslk, zl, & + var, oc1, & + oa2d1, oa2d2, & + oa2d3, oa2d4, & + ol2d1, ol2d2, & + ol2d3, ol2d4, & + g_, cp_, rd_, rv_, fv_, pi_, & + dxmeter, deltim, & + its, ite, kte, kme, & + errmsg, errflg ) +!------------------------------------------------------------------------------- +! +! abstract : +! 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 +! choi and hong (2015), which names kim gwdo since it was developed by +! kiaps staffs for kiaps integrated model system (kim). the scheme +! additionally includes the effects of orographic anisotropy and +! flow-blocking drag. +! coded by song-you hong and young-joon kim and implemented by song-you hong +! +! history log : +! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy +! +! references : +! choi and hong (2015), j. geophys. res. +! hong et al. (2008), wea. forecasting +! kim and doyle (2005), q. j. r. meteor. soc. +! kim and arakawa (1995), j. atmos. sci. +! alpet et al. (1988), NWP conference +! hong (1999), NCEP office note 424 +! +! input : +! dudt, dvdt - non-lin tendency for u and v wind component +! uproj, vproj - projection-relative U and V m/sec +! u1, v1 - zonal and meridional wind m/sec at t0-dt +! t1 - temperature deg k at t0-dt +! q1 - mixing ratio at t0-dt +! deltim - time step (s) +! del - positive increment of pressure across layer (pa) +! prslk, zl, prsl, prsi - pressure and height variables +! oa4, ol4, omax, var, oc1 - orographic statistics +! +! output : +! dudt, dvdt - wind tendency due to gwdo +! dtaux2d, dtauy2d - diagnoised orographic gwd +! dusfc, dvsfc - gw stress +! +!------------------------------------------------------------------------------- + implicit none +! + integer, parameter :: kts = 1 + integer , intent(in ) :: its, ite, kte, kme + real(kind=kind_phys) , intent(in ) :: g_, pi_, rd_, rv_, fv_,& + cp_, deltim + real(kind=kind_phys), dimension(its:) , intent(in ) :: dxmeter + real(kind=kind_phys), dimension(its:,:) , intent(inout) :: rublten, rvblten + real(kind=kind_phys), dimension(its:,:) , intent( out) :: dtaux3d, dtauy3d + real(kind=kind_phys), dimension(its:) , intent( out) :: dusfcg, dvsfcg + real(kind=kind_phys), dimension(its:) , intent(in ) :: sina, cosa + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: uproj, vproj + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: t1, q1, prslk, zl +! + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: prsl + real(kind=kind_phys), dimension(its:,:) , intent(in ) :: prsi +! + real(kind=kind_phys), dimension(its:) , intent(in ) :: var, oc1, & + oa2d1, oa2d2, oa2d3, oa2d4, & + ol2d1, ol2d2, ol2d3, ol2d4 + character(len=*) , intent( out) :: errmsg + integer , intent( out) :: errflg +! + real(kind=kind_phys), parameter :: ric = 0.25 ! critical richardson number + real(kind=kind_phys), parameter :: dw2min = 1. + real(kind=kind_phys), parameter :: rimin = -100. + real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 + real(kind=kind_phys), parameter :: efmin = 0.0 + real(kind=kind_phys), parameter :: efmax = 10.0 + real(kind=kind_phys), parameter :: xl = 4.0e4 + real(kind=kind_phys), parameter :: critac = 1.0e-5 + real(kind=kind_phys), parameter :: gmax = 1. + real(kind=kind_phys), parameter :: veleps = 1.0 + real(kind=kind_phys), parameter :: frc = 1.0 + real(kind=kind_phys), parameter :: ce = 0.8 + real(kind=kind_phys), parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 +! +! local variables +! + integer :: kpblmax + integer :: latd,lond + integer :: i,k,lcap,lcapp1,nwd,idir, & + klcap,kp1,ikount,kk +! + real(kind=kind_phys) :: fdir,cs,rcsks, & + wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & + wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & + temv,dtaux,dtauy +! + real(kind=kind_phys), dimension(its:ite,kts:kte) :: dudt, dvdt + real(kind=kind_phys), dimension(its:ite,kts:kte) :: dtaux2d, dtauy2d + real(kind=kind_phys), dimension(its:ite) :: dusfc, dvsfc + logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 + real(kind=kind_phys), dimension(its:ite) :: coefm +! + real(kind=kind_phys), dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & + ulow, rulow, bnv, oa, ol, rhobar, & + dtfac, brvf, xlinv, delks,delks1, & + zlowtop,cleff + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taup + real(kind=kind_phys), dimension(its:ite,kts:kte-1) :: velco + real(kind=kind_phys), dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj + real(kind=kind_phys), dimension(its:ite,kts:kte) :: del + real(kind=kind_phys), dimension(its:ite,kts:kte) :: u1, v1 + real(kind=kind_phys), dimension(its:ite,4) :: oa4, ol4 +! + integer, dimension(its:ite) :: kbl, klowtop + integer, parameter :: mdir=8 + integer, dimension(mdir) :: nwdir + data nwdir/6,7,5,8,2,3,1,4/ +! +! variables for flow-blocking drag +! + real(kind=kind_phys), parameter :: frmax = 10. + real(kind=kind_phys), parameter :: olmin = 1.0e-5 + real(kind=kind_phys), parameter :: odmin = 0.1 + real(kind=kind_phys), parameter :: odmax = 10. +! + real(kind=kind_phys) :: fbdcd + real(kind=kind_phys) :: zblk, tautem + real(kind=kind_phys) :: fbdpe, fbdke + real(kind=kind_phys), dimension(its:ite) :: delx, dely + real(kind=kind_phys), dimension(its:ite,4) :: dxy4, dxy4p + real(kind=kind_phys), dimension(4) :: ol4p + real(kind=kind_phys), dimension(its:ite) :: dxy, dxyp, olp, od + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taufb +! + integer, dimension(its:ite) :: komax + integer :: kblk +!------------------------------------------------------------------------------- +! +! constants +! + lcap = kte + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi_) +! +! initialize CCPP error flag and message +! + errmsg = '' + errflg = 0 +! +! calculate length of grid for flow-blocking drag +! + delx(its:ite) = dxmeter(its:ite) + dely(its:ite) = dxmeter(its:ite) + dxy4(its:ite,1) = delx(its:ite) + dxy4(its:ite,2) = dely(its:ite) + dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) + dxy4(its:ite,4) = dxy4(its:ite,3) + dxy4p(its:ite,1) = dxy4(its:ite,2) + dxy4p(its:ite,2) = dxy4(its:ite,1) + dxy4p(its:ite,3) = dxy4(its:ite,4) + dxy4p(its:ite,4) = dxy4(its:ite,3) +! + cleff(its:ite) = dxmeter(its:ite) +! +! initialize arrays, array syntax is OK for OpenMP since these are local +! + ldrag = .false. ; icrilv = .false. ; flag = .true. +! + klowtop = 0 ; kbl = 0 +! + dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. + ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. + oa = 0. ; ol = 0. ; taub = 0. +! + usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. + taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. +! + dtfac = 1.0 ; xlinv = 1.0/xl +! + komax = 0 + taufb = 0.0 +! + 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) + + ! Density (kg/m^3) + + rho(i,k) = 1./rd_ * prsl(i,k) / vtj(i,k) + + ! Delta p (positive) between interfaces levels (Pa) + + del(i,k) = prsi(i,k) - prsi(i,k+1) + + ! Earth-relative zonal and meridional winds (m/s) + + u1(i,k) = uproj(i,k)*cosa(i) - vproj(i,k)*sina(i) + v1(i,k) = uproj(i,k)*sina(i) + vproj(i,k)*cosa(i) + + enddo + enddo + +! + do i = its,ite + zlowtop(i) = 2. * var(i) + enddo +! + do i = its,ite + kloop1(i) = .true. + enddo +! + do k = kts+1,kte + do i = its,ite + if(zlowtop(i) .gt. 0.) then + if (kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then + klowtop(i) = k+1 + kloop1(i) = .false. + endif + endif + enddo + enddo +! + kpblmax = kte + do i = its,ite + kbl(i) = klowtop(i) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) + enddo +! +! determine the level of maximum orographic height +! + komax(:) = kbl(:) +! + 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 +! +! compute low level averages within pbl +! + do k = kts,kpblmax + do i = its,ite + if (k.lt.kbl(i)) then + rcsks = del(i,k) * delks(i) + rdelks = 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 + rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho 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 + oa4(i,1) = oa2d1(i) + oa4(i,2) = oa2d2(i) + oa4(i,3) = oa2d3(i) + oa4(i,4) = oa2d4(i) + ol4(i,1) = ol2d1(i) + ol4(i,2) = ol2d2(i) + ol4(i,3) = ol2d3(i) + ol4(i,4) = ol2d4(i) + 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) +! +! compute orographic width along (ol) and perpendicular (olp) the wind direction +! + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) +! +! compute orographic direction (horizontal orographic aspect ratio) +! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) +! +! compute length of grid in the along(dxy) and cross(dxyp) wind directions +! + dxy(i) = dxy4(i,MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) + 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 = 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.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + 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 * ((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 +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.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 phy_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 = kpblmin,kpblmax + 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 = kpblmin,kpblmax + 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) * od(i) + fr(i) = min(fr(i),frmax) + 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(i) = (1. + ol(i)) ** (oa(i)+1.) + xlinv(i) = coefm(i) / cleff(i) + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + taub(i) = xlinv(i) * rhobar(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. +! + 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 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(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. kpblmin )) 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 + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + do i = its,ite + if (.not.ldrag(i)) then +! +! determine the height of flow-blocking layer +! + kblk = 0 + fbdpe = 0.0 + fbdke = 0.0 + do k = kte, kpblmin, -1 + if (kblk.eq.0 .and. k.le.kbl(i)) then + fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & + *del(i,k)/g_/rho(i,k) + fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) +! +! apply flow-blocking drag when fbdpe >= fbdke +! + if (fbdpe.ge.fbdke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + endif + endif + enddo + if (kblk.ne.0) then +! +! compute flow-blocking stress +! + fbdcd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter(i)**2*fbdcd*dxyp(i) & + *olp(i)*zblk*ulow(i)**2 + tautem = taufb(i,kts)/real(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +! sum orographic GW stress and flow-blocking stress +! + taup(i,:) = taup(i,:) + taufb(i,:) + endif + endif + enddo +! +! 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)) * g_ / del(i,k) + 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*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 + dvdt(i,k) = dtauy + 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_) * dusfc(i) + dvsfc(i) = (-1./g_) * dvsfc(i) + enddo +! +! rotate tendencies from zonal/meridional back to model grid +! + do k = kts,kte + do i = its,ite + rublten(i,k) = rublten(i,k)+dudt(i,k)*cosa(i) + dvdt(i,k)*sina(i) + rvblten(i,k) = rvblten(i,k)-dudt(i,k)*sina(i) + dvdt(i,k)*cosa(i) + dtaux3d(i,k) = dtaux2d(i,k)*cosa(i) + dtauy2d(i,k)*sina(i) + dtauy3d(i,k) =-dtaux2d(i,k)*sina(i) + dtauy2d(i,k)*cosa(i) + enddo + enddo + do i = its,ite + dusfcg(i) = dusfc(i)*cosa(i) + dvsfc(i)*sina(i) + dvsfcg(i) =-dusfc(i)*sina(i) + dvsfc(i)*cosa(i) + enddo + return + end subroutine bl_gwdo_run + + +!================================================================================================================= + end module bl_gwdo +!================================================================================================================= + diff --git a/phys/physics_mmm/bl_ysu.F90 b/phys/physics_mmm/bl_ysu.F90 new file mode 100644 index 0000000000..710fa65cf9 --- /dev/null +++ b/phys/physics_mmm/bl_ysu.F90 @@ -0,0 +1,1696 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 +!================================================================================================================= + module bl_ysu + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: bl_ysu_run, & + bl_ysu_init, & + bl_ysu_finalize + + + contains + + +!================================================================================================================= +!>\section arg_table_bl_ysu_init +!!\html\include bl_ysu_init.html +!! + subroutine bl_ysu_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_ysu_init OK' + errflg = 0 + + end subroutine bl_ysu_init + +!================================================================================================================= +!>\section arg_table_bl_ysu_finalize +!!\html\include bl_ysu_finalize.html +!! + subroutine bl_ysu_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'bl_ysu_finalize OK' + errflg = 0 + + end subroutine bl_ysu_finalize + +!================================================================================================================= +!>\section arg_table_bl_ysu_run +!!\html\include bl_ysu_run.html +!! + subroutine bl_ysu_run(ux,vx,tx,qvx,qcx,qix,nmix,qmix,p2d,p2di,pi2d, & + f_qc,f_qi, & + utnp,vtnp,ttnp,qvtnp,qctnp,qitnp,qmixtnp, & + cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & + dz8w2d,psfcpa, & + znt,ust,hpbl,dusfc,dvsfc,dtsfc,dqsfc,psim,psih, & + xland,hfx,qfx,wspd,br, & + dt,kpbl1d, & + exch_hx,exch_mx, & + wstar,delta, & + u10,v10, & + uox,vox, & + rthraten, & + ysu_topdown_pblmix, & + ctopo,ctopo2, & + a_u,a_v,a_t,a_q,a_e, & + b_u,b_v,b_t,b_q,b_e, & + sfk,vlk,dlu,dlg,frcurb, & + flag_bep, & + its,ite,kte,kme, & + errmsg,errflg & + ) +!------------------------------------------------------------------------------- + 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 neutral, 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 psim psih are ln(z1/z0)-psim,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 +! add multilayer urban canopy models of BEP and BEP+BEM, jan 2021 +! +! references: +! +! hendricks, knievel, and wang (2020), j. appl. meteor. clim. +! 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(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + integer,parameter :: imvdif = 1 + real(kind=kind_phys),parameter :: rcl = 1.0 + integer,parameter :: kts=1, kms=1 +! + integer, intent(in ) :: its,ite,kte,kme + + logical, intent(in) :: ysu_topdown_pblmix +! + integer, intent(in) :: nmix +! + real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv +! + real(kind=kind_phys), intent(in ) :: ep1,ep2,karman +! + logical, intent(in ) :: f_qc, f_qi +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in) :: dz8w2d, & + pi2d +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: tx, & + qvx, & + qcx, & + qix +! + real(kind=kind_phys), dimension( its:,:,: ) , & + intent(in ) :: qmix +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(out ) :: utnp, & + vtnp, & + ttnp, & + qvtnp, & + qctnp, & + qitnp +! + real(kind=kind_phys), dimension( its:,:,: ) , & + intent(out ) :: qmixtnp +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: p2di +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: p2d +! + real(kind=kind_phys), dimension( its: ) , & + intent(out ) :: hpbl +! + real(kind=kind_phys), dimension( its: ) , & + intent(out ), optional :: dusfc, & + dvsfc, & + dtsfc, & + dqsfc +! + real(kind=kind_phys), dimension( its: ) , & + intent(in ) :: ust, & + znt + real(kind=kind_phys), dimension( its: ) , & + intent(in ) :: xland, & + hfx, & + qfx +! + real(kind=kind_phys), dimension( its: ), intent(in ) :: wspd + real(kind=kind_phys), dimension( its: ), intent(in ) :: br +! + real(kind=kind_phys), dimension( its: ), intent(in ) :: psim, & + psih +! + real(kind=kind_phys), dimension( its: ), intent(in ) :: psfcpa + integer, dimension( its: ), intent(out ) :: kpbl1d +! + real(kind=kind_phys), dimension( its:,: ) , & + intent(in ) :: ux, & + vx, & + rthraten + real(kind=kind_phys), dimension( its: ) , & + optional , & + intent(in ) :: ctopo, & + ctopo2 +! + logical, intent(in ) :: flag_bep + real(kind=kind_phys), dimension( its:,: ) , & + optional , & + intent(in ) :: a_u, & + a_v, & + a_t, & + a_q, & + a_e, & + b_u, & + b_v, & + b_t, & + b_q, & + b_e, & + sfk, & + vlk, & + dlu, & + dlg + real(kind=kind_phys), dimension( its: ) , & + optional , & + intent(in ) :: frcurb +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! +! local vars +! + real(kind=kind_phys), dimension( its:ite ) :: hol + real(kind=kind_phys), dimension( its:ite, kms:kme ) :: zq +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za +! + real(kind=kind_phys), dimension( its:ite ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzh,xkzm,xkzq, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + zfac, & + rhox2, & + hgamt2, & + ad1,adm,adv +! +!jdf added exch_hx +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(out ) :: exch_hx, & + exch_mx +! + real(kind=kind_phys), dimension( its:ite ) , & + intent(inout) :: u10, & + v10 + real(kind=kind_phys), dimension( its:ite ), optional , & + intent(in ) :: uox, & + vox + real(kind=kind_phys), dimension( its:ite ) :: uoxl, & + voxl + real(kind=kind_phys), dimension( its:ite ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys), dimension( its:ite, kts:kte) :: r3,f3 + integer, dimension( its:ite ) :: kpbl,kpblold +! + logical, dimension( its:ite ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl +! +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc +! + + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: wscalek,wscalek2 + real(kind=kind_phys), dimension( its:ite ), intent(out) :: wstar, & + delta + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: qcxl, & + qixl + real(kind=kind_phys), dimension( its:ite ) :: ust3, & + wstar3, & + wstar3_2, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys) :: 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,vconvlim,vconvnew,fluxc,vconvc,vconv +!topo-corr + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: fric, & + tke_ysu,& + el_ysu,& + shear_ysu,& + buoy_ysu + real(kind=kind_phys), dimension( its:ite) :: pblh_ysu,& + vconvfx +! + real(kind=kind_phys) :: bepswitch + + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & + a_u2d,a_v2d,a_t2d,a_q2d,a_e2d,b_u2d,b_v2d,b_t2d,b_q2d,b_e2d, & + sfk2d,vlk2d,dlu2d,dlg2d + real(kind=kind_phys), dimension( its:ite ) :: & + frc_urb1d + + real(kind=kind_phys), dimension( kts:kte ) :: thvx_1d,tke_1d,dzq_1d + real(kind=kind_phys), dimension( kts:kte+1) :: zq_1d + +! +!------------------------------------------------------------------------------- +! + 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 +! + if(f_qc) then + do k = kts,kte + do i = its,ite + qcxl(i,k) = qcx(i,k) + enddo + enddo + else + do k = kts,kte + do i = its,ite + qcxl(i,k) = 0. + enddo + enddo + endif +! + if(f_qi) then + do k = kts,kte + do i = its,ite + qixl(i,k) = qix(i,k) + enddo + enddo + else + do k = kts,kte + do i = its,ite + qixl(i,k) = 0. + enddo + enddo + endif +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qcxl(i,k)/cp-2.834E6*qixl(i,k)/cp)/pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qvx(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + if ( present(uox) .and. present(vox) ) then + do i =its,ite + uoxl(i) = uox(i) + voxl(i) = vox(i) + enddo + else + do i =its,ite + uoxl(i) = 0 + voxl(i) = 0 + enddo + endif +! + do i = its,ite + tvcon = (1.+ep1*qvx(i,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + enddo +! + if(present(a_u) .and. present(a_v) .and. present(a_t) .and. & + present(a_q) .and. present(a_t) .and. present(a_e) .and. & + present(b_u) .and. present(b_v) .and. present(b_t) .and. & + present(b_q) .and. present(b_e) .and. present(dlg) .and. & + present(dlu) .and. present(sfk) .and. present(vlk) .and. & + present(frcurb) .and. flag_bep) then + + bepswitch=1.0 + do k = kts, kte + do i = its,ite + a_u2d(i,k) = a_u(i,k) + a_v2d(i,k) = a_v(i,k) + a_t2d(i,k) = a_t(i,k) + a_q2d(i,k) = a_q(i,k) + a_e2d(i,k) = a_e(i,k) + b_u2d(i,k) = b_u(i,k) + b_v2d(i,k) = b_v(i,k) + b_t2d(i,k) = b_t(i,k) + b_q2d(i,k) = b_q(i,k) + b_e2d(i,k) = b_e(i,k) + dlg2d(i,k) = dlg(i,k) + dlu2d(i,k) = dlu(i,k) + vlk2d(i,k) = vlk(i,k) + sfk2d(i,k) = sfk(i,k) + enddo + enddo + do i = its, ite + frc_urb1d(i) = frcurb(i) + enddo + else + bepswitch=0.0 + do k = kts, kte + do i = its,ite + a_u2d(i,k) = 0.0 + a_v2d(i,k) = 0.0 + a_t2d(i,k) = 0.0 + a_q2d(i,k) = 0.0 + a_e2d(i,k) = 0.0 + b_u2d(i,k) = 0.0 + b_v2d(i,k) = 0.0 + b_t2d(i,k) = 0.0 + b_q2d(i,k) = 0.0 + b_e2d(i,k) = 0.0 + dlg2d(i,k) = 0.0 + dlu2d(i,k) = 0.0 + vlk2d(i,k) = 1.0 + sfk2d(i,k) = 1.0 + enddo + enddo + do i = its, ite + frc_urb1d(i) = 0.0 + enddo + endif +! +!-----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*qvx(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 output and local exchange coefficents: + do k = kts,kte + do i = its,ite + exch_hx(i,k) = 0. + exch_mx(i,k) = 0. + xkzh(i,k) = 0. + xkzhl(i,k) = 0. + xkzm(i,k) = 0. + xkzml(i,k) = 0. + xkzq(i,k) = 0. + enddo + enddo +! + do i = its,ite + wspd1(i) = sqrt( (ux(i,1)-uoxl(i))*(ux(i,1)-uoxl(i)) + (vx(i,1)-voxl(i))*(vx(i,1)-voxl(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 +! + 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 + if(present(dusfc)) dusfc(i) = 0. + if(present(dvsfc)) dvsfc(i) = 0. + if(present(dtsfc)) dtsfc(i) = 0. + if(present(dqsfc)) 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)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 + + 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((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and.ysu_topdown_pblmix)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 + ((qvx(i,k)+qcxl(i,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((qvx(i,k)+qcxl(i,k))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qvx(i,k+2)+qcxl(i,k+2))) & + - (thlix(i,k) + thx(i,k) *ep1*(qvx(i,k) +qcxl(i,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 + + 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*(p2di(i,kk)-p2di(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !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))) + + !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)) + + !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(qvx(i,k+1)-qvx(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)then + if((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and. & + (qcxl(i,k+1)+qixl(i,k+1)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qvx(i,k)+qvx(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.+(1.0-bepswitch)*hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*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/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + 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 +! +! add bep/bep+bem forcing for heat if flag_bep=.true. +! + do k = kts,kte + do i = its,ite + ad(i,k) = ad(i,k) - a_t2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_t2d(i,k)*dt2 + 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 +#if (NEED_B4B_DURING_CCPP_TESTING == 1) + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttend + if(present(dtsfc)) dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) +#elif (NEED_B4B_DURING_CCPP_TESTING != 1) + ttend = (f1(i,k)-thx(i,k)+300.)*rdt + ttnp(i,k) = ttend + if(present(dtsfc)) dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) +#endif + enddo + enddo +! + +!--- compute tridiagonal matrix elements for water vapor, cloud water, and cloud ice: + !--- initialization of k-coefficient above the PBL. + do i = its,ite + do k = kts,kte-1 + if(k .ge. kpbl(i)) xkzq(i,k) = xkzh(i,k) + enddo + enddo + + !--- water vapor: + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + r1(i,k) = 0. + enddo + + k = 1 + ad(i,1) = 1. + f1(i,1) = qvx(i,1)+(1.0-bepswitch)*qfx(i)*g/del(i,1)*dt2 + + do k = kts,kte-1 + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*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)) + f1(i,k) = f1(i,k)+dtodsd*dsdzq + f1(i,k+1) = qvx(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) + f1(i,k+1) = qvx(i,k+1) + else + f1(i,k+1) = qvx(i,k+1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo +! +! add bep/bep+bem forcing for water vapor if flag_bep=.true. +! + do k = kts,kte + adv(i,k) = ad(i,k) - a_q2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_q2d(i,k)*dt2 + enddo + + do k = kts,kte + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,adv,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qvx(i,k))*rdt + qvtnp(i,k) = qtend + if(present(dqsfc)) dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo + + !--- cloud water: + if(f_qc) then + do i = its,ite + do k = kts,kte + f1(i,k) = qcxl(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qcxl(i,k))*rdt + qctnp(i,k) = qtend + enddo + enddo + endif + + !--- cloud ice: + if(f_qi) then + do i = its,ite + do k = kts,kte + f1(i,k) = qixl(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qixl(i,k))*rdt + qitnp(i,k) = qtend + enddo + enddo + endif + + !--- chemical species and/or passive tracers, meaning all variables that we want to + ! be vertically-mixed, if nmix=0 (number of tracers) then the loop is skipped + do n = 1, nmix + do i = its,ite + do k = kts,kte + f1(i,k) = qmix(i,k,n) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qmix(i,k,n))*rdt + qmixtnp(i,k,n) = qtend + enddo + enddo + enddo + +! +! 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 +! +! paj: ctopo=1 if topo_wind=0 (default) +!raquel---paj tke code (could be replaced with shin-hong tke in future + do i = its,ite + do k= kts, kte-1 + shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & + + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) + buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) + + zk = karman*zq(i,k+1) + !over pbl + if (k.ge.kpbl(i)) then + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + else + !in pbl + rlamdz = 150.0 + endif + el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) + tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)) + !q2 when q3 positive + if(tke_ysu(i,k).le.0) then + tke_ysu(i,k)=0.0 + else + tke_ysu(i,k)=(tke_ysu(i,k))**0.66 + endif + enddo + !Hybrid pblh of MYNN + !tke is q2 +! CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& +! & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) + do k = kts,kte + thvx_1d(k) = thvx(i,k) + tke_1d(k) = tke_ysu(i,k) + zq_1d(k) = zq(i,k) + dzq_1d(k) = dzq(i,k) + enddo + zq_1d(kte+1) = zq(i,kte+1) + call get_pblh(kts,kte,pblh_ysu(i),thvx_1d,tke_1d,zq_1d,dzq_1d,xland(i)) + +!--- end of paj tke +! compute vconv +! Use Beljaars over land + if (xland(i).lt.1.5) then + fluxc = max(sflux(i),0.0) + vconvc=1. + VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 + else +! for water there is no topo effect so vconv not needed + VCONV = 0. + endif + vconvfx(i) = vconv +!raquel +!ctopo stability correction + fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + if(present(ctopo)) then + vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) + vconvlim = min(vconvnew,1.0) + ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim) + ad(i,1) = ad(i,1) - bepswitch*frc_urb1d(i)* & + (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) +! ad(i,1) = 1.+(1.-bepswitch*frc_urb1d(i))* & +! (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) + else + ad(i,1) = 1.+fric(i,1) + endif + f1(i,1) = ux(i,1)+uoxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + f2(i,1) = vx(i,1)+voxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*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/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_mx(i,k+1) = xkzm(i,k) + enddo + enddo +! +! add bep/bep+bem forcing for momentum if flag_bep=.true. +! + do k = kts,kte + do i = its,ite + ad1(i,k) = ad(i,k) + end do + end do + do k = kts,kte + do i = its,ite + ad(i,k) = ad(i,k) - a_u2d(i,k)*dt2 + ad1(i,k) = ad1(i,k) - a_v2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_u2d(i,k)*dt2 + f2(i,k) = f2(i,k) + b_v2d(i,k)*dt2 + 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 tridi2n(al,ad,ad1,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) = utend + vtnp(i,k) = vtend + if(present(dusfc)) dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + if(present(dvsfc)) 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 +! + errmsg = 'bl_ysu_run OK' + errflg = 0 +! + end subroutine bl_ysu_run + +!================================================================================================================= + subroutine tridi2n(cl,cm,cm1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + cm1, & + r1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: 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./cm1(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./(cm1(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./(cm1(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 tridi2n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + 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(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: au, & + cm, & + cu + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 + + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: aul + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,ite + do k = kts,kte + aul(i,k) = 0. + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + aul(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)*aul(i,k-1)) + aul(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)*aul(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)-aul(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu + +!================================================================================================================= + subroutine get_pblh(kts,kte,zi,thetav1d,qke1d,zw1d,dz1d,landsea) +! Copied from MYNN PBL + + !--------------------------------------------------------------- + ! 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(kind=kind_phys), intent(out) :: zi + real(kind=kind_phys), intent(in) :: landsea + real(kind=kind_phys), dimension(kts:kte), intent(in) :: thetav1d, qke1d, dz1d + real(kind=kind_phys), dimension(kts:kte+1), intent(in) :: zw1d + !local vars + real(kind=kind_phys) :: pblh_tke,qtke,qtkem1,wt,maxqke,tkeeps,minthv + real(kind=kind_phys) :: delt_thv !delta theta-v; dependent on land/sea point + real(kind=kind_phys), parameter :: sbl_lim = 200. !theta-v pbl lower limit of trust (m). + real(kind=kind_phys), parameter :: sbl_damp = 400. !damping range for averaging with tke-based pblh (m). + integer :: i,j,k,kthv,ktke + + !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) + tkeeps = min(tkeeps,0.25) + + !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.5 + endif + + zi=0. + k = kthv+1 + do while (zi .eq. 0.) + if (thetav1d(k) .ge. (minthv + delt_thv))then + zi = zw1d(k) - dz1d(k-1)* & + & min((thetav1d(k)-(minthv + delt_thv))/max(thetav1d(k)-thetav1d(k-1),1e-6),1.0) + endif + k = k+1 + if (k .eq. kte-1) zi = zw1d(kts+1) !exit safeguard + 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. + !find tke-based pblh (best for nocturnal/stable conditions). + + 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 + 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 + + !blend the two pblh types here: + + wt=.5*tanh((zi - sbl_lim)/sbl_damp) + .5 + zi=pblh_tke*(1.-wt) + zi*wt + + end subroutine get_pblh + +!================================================================================================================= + end module bl_ysu +!================================================================================================================= diff --git a/phys/physics_mmm/cu_ntiedtke.F90 b/phys/physics_mmm/cu_ntiedtke.F90 new file mode 100644 index 0000000000..e1d266d06f --- /dev/null +++ b/phys/physics_mmm/cu_ntiedtke.F90 @@ -0,0 +1,3594 @@ +!================================================================================================================= + module cu_ntiedtke_common + use ccpp_kind_types,only: kind_phys + + + implicit none + save + + real(kind=kind_phys):: alf + real(kind=kind_phys):: als + real(kind=kind_phys):: alv + real(kind=kind_phys):: cpd + real(kind=kind_phys):: g + real(kind=kind_phys):: rd + real(kind=kind_phys):: rv + + real(kind=kind_phys),parameter:: t13 = 1.0/3.0 + real(kind=kind_phys),parameter:: tmelt = 273.16 + real(kind=kind_phys),parameter:: c1es = 610.78 + real(kind=kind_phys),parameter:: c3les = 17.2693882 + real(kind=kind_phys),parameter:: c3ies = 21.875 + real(kind=kind_phys),parameter:: c4les = 35.86 + real(kind=kind_phys),parameter:: c4ies = 7.66 + + real(kind=kind_phys),parameter:: rtwat = tmelt + real(kind=kind_phys),parameter:: rtber = tmelt-5. + real(kind=kind_phys),parameter:: rtice = tmelt-23. + + integer,parameter:: momtrans = 2 + real(kind=kind_phys),parameter:: entrdd = 2.0e-4 + real(kind=kind_phys),parameter:: cmfcmax = 1.0 + real(kind=kind_phys),parameter:: cmfcmin = 1.e-10 + real(kind=kind_phys),parameter:: cmfdeps = 0.30 + real(kind=kind_phys),parameter:: zdnoprc = 2.0e4 + real(kind=kind_phys),parameter:: cprcon = 1.4e-3 + real(kind=kind_phys),parameter:: pgcoef = 0.7 + + real(kind=kind_phys):: rcpd + real(kind=kind_phys):: c2es + real(kind=kind_phys):: c5les + real(kind=kind_phys):: c5ies + real(kind=kind_phys):: r5alvcp + real(kind=kind_phys):: r5alscp + real(kind=kind_phys):: ralvdcp + real(kind=kind_phys):: ralsdcp + real(kind=kind_phys):: ralfdcp + real(kind=kind_phys):: vtmpc1 + real(kind=kind_phys):: zrg + + logical,parameter:: nonequil = .true. + logical,parameter:: lmfpen = .true. + logical,parameter:: lmfmid = .true. + logical,parameter:: lmfscv = .true. + logical,parameter:: lmfdd = .true. + logical,parameter:: lmfdudv = .true. + + +!================================================================================================================= + end module cu_ntiedtke_common +!================================================================================================================= + + module cu_ntiedtke + use ccpp_kind_types,only: kind_phys + use cu_ntiedtke_common + + + implicit none + private + public:: cu_ntiedtke_run, & + cu_ntiedtke_init, & + cu_ntiedtke_finalize + + + contains + + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_init +!!\html\include cu_ntiedtke_init.html +!! + subroutine cu_ntiedtke_init(con_cp,con_rd,con_rv,con_xlv,con_xls,con_xlf,con_grav,errmsg,errflg) +!================================================================================================================= + +!input arguments: + real(kind=kind_phys),intent(in):: & + con_cp, & + con_rd, & + con_rv, & + con_xlv, & + con_xls, & + con_xlf, & + con_grav + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + alf = con_xlf + als = con_xls + alv = con_xlv + cpd = con_cp + g = con_grav + rd = con_rd + rv = con_rv + + rcpd = 1.0/con_cp + c2es = c1es*con_rd/con_rv + c5les = c3les*(tmelt-c4les) + c5ies = c3ies*(tmelt-c4ies) + r5alvcp = c5les*con_xlv*rcpd + r5alscp = c5ies*con_xls*rcpd + ralvdcp = con_xlv*rcpd + ralsdcp = con_xls*rcpd + ralfdcp = con_xlf*rcpd + vtmpc1 = con_rv/con_rd-1.0 + zrg = 1.0/con_grav + + errmsg = 'cu_ntiedtke_init OK' + errflg = 0 + + end subroutine cu_ntiedtke_init + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_finalize +!!\html\include cu_ntiedtke_finalize.html +!! + subroutine cu_ntiedtke_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'cu_ntiedtke_finalize OK' + errflg = 0 + + end subroutine cu_ntiedtke_finalize + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_run +!!\html\include cu_ntiedtke_run.html +!! +! level 1 subroutine 'cu_ntiedkte_run' + subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & + & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx,errmsg,errflg) +!================================================================================================================= +! this is the interface between the model and the mass flux convection module +! m.tiedtke e.c.m.w.f. 1989 +! j.morcrette 1992 +!-------------------------------------------- +! modifications +! C. zhang & Yuqing Wang 2011-2017 +! +! 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 reference: tiedtke (1989, mwr, 117, 1779-1800) +! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 +! +! Note for climate simulation of Tropical Cyclones +! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation +! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km +! Set: momtrans = 2. +! pgcoef = 0.7 to 1.0 is good depends on the basin +! nonequil = .false. + +! Note for the diurnal simulation of precipitaton +! When nonequil = .true., the CAPE is relaxed toward to a value from PBL +! It can improve the diurnal precipitation over land. + +!--- input arguments: + integer,intent(in):: lq,km,km1 + integer,intent(in),dimension(:):: lndj + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(:):: dx + real(kind=kind_phys),intent(in),dimension(:):: evap,hfx + real(kind=kind_phys),intent(in),dimension(:,:):: pqvf,ptf + real(kind=kind_phys),intent(in),dimension(:,:):: poz,pomg,pap + real(kind=kind_phys),intent(in),dimension(:,:):: pzz,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(:):: zprecc + real(kind=kind_phys),intent(inout),dimension(:,:):: pu,pv,pt,pqv,pqc,pqi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + logical,dimension(lq):: locum + integer:: i,j,k + integer,dimension(lq):: icbot,ictop,ktype + + real(kind=kind_phys):: ztmst,fliq,fice,ztc,zalf,tt + real(kind=kind_phys):: ztpp1,zew,zqs,zcor + real(kind=kind_phys):: dxref + + real(kind=kind_phys),dimension(lq):: pqhfl,prsfc,pssfc,phhfl,zrain + real(kind=kind_phys),dimension(lq):: scale_fac,scale_fac2 + + real(kind=kind_phys),dimension(lq,km):: pum1,pvm1,ztt,ptte,pqte,pvom,pvol,pverv,pgeo + real(kind=kind_phys),dimension(lq,km):: zqq,pcte + real(kind=kind_phys),dimension(lq,km):: ztp1,zqp1,ztu,zqu,zlu,zlude,zmfu,zmfd,zqsat + real(kind=kind_phys),dimension(lq,km1):: pgeoh + +!----------------------------------------------------------------------------------------------------------------- +! + ztmst=dt +! +! set scale-dependency factor when dx is < 15 km +! + dxref = 15000. + do j=1,lq + if (dx(j).lt.dxref) then + scale_fac(j) = (1.06133+log(dxref/dx(j)))**3 + scale_fac2(j) = scale_fac(j)**0.5 + else + scale_fac(j) = 1.+1.33e-5*dx(j) + scale_fac2(j) = 1. + end if + end do +! +! 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, & + & scale_fac, scale_fac2) +! +! 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 +! + errmsg = 'cu_ntiedtke_run OK' + errflg = 0 +! + return + end subroutine cu_ntiedtke_run + +!############################################################# +! +! 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, & + & scale_fac, scale_fac2) + 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) +!----------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klev,klon,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon):: dx + real(kind=kind_phys),intent(in),dimension(klon):: pqhfl,phhfl + real(kind=kind_phys),intent(in),dimension(klon):: scale_fac,scale_fac2 + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,puen,pven,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,zgeoh + +!--- inout arguments: + integer,intent(inout),dimension(klon):: ktype,kcbot,kctop + logical,intent(inout),dimension(klon):: ldcum + + real(kind=kind_phys),intent(inout),dimension(klon):: pqsen + real(kind=kind_phys),intent(inout),dimension(klon):: prsfc,pssfc,prain + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pcte,ptte,pqte,pvom,pvol + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,plude,pmfu,pmfd + +!--- local variables and arrays: + logical:: llo1 + logical,dimension(klon):: loddraf,llo2 + + integer:: jl,jk,ik + integer:: ikb,ikt,icum,itopm2 + integer,dimension(klon):: kdpl,idtop,ictop0,ilwmin + integer,dimension(klon,klev):: ilab + + real(kind=kind_phys):: zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax + real(kind=kind_phys):: zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat + real(kind=kind_phys):: zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed + real(kind=kind_phys):: zduten,zdvten,ztdis,pgf_u,pgf_v + real(kind=kind_phys):: zlon + real(kind=kind_phys):: ztau,zerate,zderate,zmfa + real(kind=kind_phys),dimension(klon):: zmfs + real(kind=kind_phys),dimension(klon):: zsfl,zcape,zcape1,zcape2,ztauc,ztaubl,zheat + real(kind=kind_phys),dimension(klon):: wup,zdqcv + real(kind=kind_phys),dimension(klon):: wbase,zmfuub + real(kind=kind_phys),dimension(klon):: upbl + real(kind=kind_phys),dimension(klon):: zhcbase,zmfub,zmfub1,zdhpbl + real(kind=kind_phys),dimension(klon):: zmfuvb,zsum12,zsum22 + real(kind=kind_phys),dimension(klon):: zrfl + real(kind=kind_phys),dimension(klev):: pmean + real(kind=kind_phys),dimension(klon,klev):: pmfude_rate,pmfdde_rate + real(kind=kind_phys),dimension(klon,klev):: zdpmel + real(kind=kind_phys),dimension(klon,klev):: zmfuus,zmfdus,zuv2,ztenu,ztenv + real(kind=kind_phys),dimension(klon,klev):: ztenh,zqenh,zqsenh,ztd,zqd + real(kind=kind_phys),dimension(klon,klev):: zmfus,zmfds,zmfuq,zmfdq,zdmfup,zdmfdp,zmful + real(kind=kind_phys),dimension(klon,klev):: zuu,zvu,zud,zvd,zlglac + real(kind=kind_phys),dimension(klon,klevp1):: pmflxr,pmflxs + +!------------------------------------------- +! 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) + ztauc(jl) = max(ztmst,ztauc(jl)) + ztauc(jl) = max(360.,ztauc(jl)) + ztauc(jl) = min(10800.,ztauc(jl)) + ztau = ztauc(jl) * scale_fac(jl) + if(nonequil) 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) = zmfub1(jl)/scale_fac2(jl) + 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 + + 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 + +! 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 + +! 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 + pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + 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 +! ---------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon,klev,klevp1,klevm1 + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh + +!--- output arguments: + integer,intent(out),dimension(klon):: klwmin + integer,intent(out),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,ptd,pqu,pqd,plu + real(kind=kind_phys),intent(out),dimension(klon,klev):: puu,pud,pvu,pvd + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfd,pmfus,pmfds,pmfuq,pmfdq + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pdmfup,pdmfdp,plude,pdpmel + +!--- local variables and arrays: + logical,dimension(klon):: loflag + integer:: jl,jk + integer:: icall,ik + real(kind=kind_phys):: zzs + real(kind=kind_phys),dimension(klon):: zph,zwmax + +!------------------------------------------------------------ +!* 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 subroutines +!-------------------------------------------------------- + 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 +!------------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon,klev,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + + real(kind=kind_phys),intent(in),dimension(klon):: qfx,hfx + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh + +!--- output arguments: + logical,intent(out),dimension(klon):: ldcum + + integer,intent(out),dimension(klon):: ktype + integer,intent(out),dimension(klon):: cubot,cutop,kdpl + integer,intent(out),dimension(klon,klev):: culab + + real(kind=kind_phys),intent(out),dimension(klon):: wbase + real(kind=kind_phys),intent(out),dimension(klon,klev):: cutu,cuqu,culu + +!--- local variables and arrays: + logical:: needreset + logical,dimension(klon):: lldcum + logical,dimension(klon):: loflag,deepflag,resetflag + + integer:: jl,jk,ik,icall,levels + integer:: nk,is,ikb,ikt + integer,dimension(klon):: kctop,kcbot + integer,dimension(klon):: zcbase,itoppacel + integer,dimension(klon,klev):: klab + + real(kind=kind_phys):: rho,part1,part2,root,conw,deltt,deltq + real(kind=kind_phys):: zz,zdken,zdq + real(kind=kind_phys):: fscale,crirh1,pp + real(kind=kind_phys):: atop1,atop2,abot + real(kind=kind_phys):: tmix,zmix,qmix,pmix + real(kind=kind_phys):: zlglac,dp + real(kind=kind_phys):: zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real(kind=kind_phys):: zpdifftop, zpdiffbot + + real(kind=kind_phys),dimension(klon):: eta,dz,coef,zqold,zph + real(kind=kind_phys),dimension(klon,klev):: dh,dhen,kup,vptu,vten + real(kind=kind_phys),dimension(klon,klev):: ptu,pqu,plu + real(kind=kind_phys),dimension(klon,klev):: zbuo,abuoy,plude + +!-------------------------------------------------------------- + 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 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,-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 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 + +!--- input arguments: + integer,intent(in):: klev,klon,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + integer,intent(in),dimension(klon):: klwmin + integer,intent(in),dimension(klon):: kdpl + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon):: wbase + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven,pqte,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh + +!--- inout arguments: + logical,intent(inout),dimension(klon):: ldcum + + integer,intent(inout):: kcum + integer,intent(inout),dimension(klon):: kcbot,kctop,kctop0 + integer,intent(inout),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(inout),dimension(klon):: phcbase + real(kind=kind_phys),intent(inout),dimension(klon):: pmfub + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,puu,pvu + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful,plude,pdmfup + +!--- output arguments: + integer,intent(out),dimension(klon):: ktype + + real(kind=kind_phys),intent(out),dimension(klon):: wup + real(kind=kind_phys),intent(out),dimension(klon,klev):: plglac,pmfude_rate + +!--- local variables and arrays: + logical:: llo2,llo3 + logical,dimension(klon):: loflag,llo1 + + integer:: jl,jk + integer::ikb,icum,itopm2,ik,icall,is,jlm,jll + integer,dimension(klon):: jlx + + real(kind=kind_phys):: zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 + real(kind=kind_phys):: zmftest,zmfmax,zqeen,zseen,zscde,zqude + real(kind=kind_phys):: zmfusk,zmfuqk,zmfulk + real(kind=kind_phys):: zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco + real(kind=kind_phys):: zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold + real(kind=kind_phys):: zrnew,zz,zdmfeu,zdmfdu,dp + real(kind=kind_phys):: zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd + real(kind=kind_phys):: atop1,atop2,abot + + real(kind=kind_phys),dimension(klon):: eta,dz,zoentr,zdpmean + real(kind=kind_phys),dimension(klon):: zph,zdmfen,zdmfde,zmfuu,zmfuv,zpbase,zqold,zluold,zprecip + real(kind=kind_phys),dimension(klon,klev):: zlrain,zbuo,kup,zodetr,pdmfen + +!-------------------------------- +!* 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.2 ) 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 ( 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 + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + + integer,intent(in):: klev + integer,intent(in),dimension(klon):: lndj + integer,intent(in),dimension(klon):: kcbot,kctop + + real(kind=kind_phys),intent(in),dimension(klon):: pmfub + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqsen,pgeo,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptu,pqu,puu,pvu,plu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon):: prfl + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pud,pvd + +!--- output arguments: + logical,intent(out),dimension(klon):: lddraf + integer,intent(out),dimension(klon):: kdtop + + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptd,pqd,pmfd,pmfds,pmfdq,pdmfdp + +!--- local variables and arrays: + logical,dimension(klon):: llo2 + integer:: jl,jk + integer:: is,ik,icall,ike + integer,dimension(klon):: ikhsmin + + real(kind=kind_phys):: zhsk,zttest,zqtest,zbuo,zmftop + real(kind=kind_phys),dimension(klon):: zcond,zph,zhsmin + real(kind=kind_phys),dimension(klon,klev):: ztenwb,zqenwb + +!---------------------------------------------------------------------- + +! 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 +! *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 + +!--- input arguments: + integer,intent(in)::klon + logical,intent(in),dimension(klon):: lddraf + + integer,intent(in)::klev + + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pmfu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon):: prfl + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptd,pqd,pud,pvd + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfd,pmfds,pmfdq,pdmfdp + +!--- output arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfdde_rate + +!--- local variables and arrays: + logical:: llo1 + logical,dimension(klon):: llo2 + + integer:: jl,jk + integer:: is,ik,icall,ike + integer,dimension(klon):: itopde + + real(kind=kind_phys):: zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real(kind=kind_phys):: zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk + real(kind=kind_phys),dimension(klon):: zdmfen,zdmfde,zcond,zoentr,zbuoy,zph + +!---------------------------------------------------------------------- +! 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 subroutines +!-------------------------------------------------------- + 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 + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum,lddraf + + integer,intent(in):: klev,ktopm2 + integer,intent(in),dimension(klon):: kctop,kdtop + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfus,pmfd,pmfds + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfuq,pmfdq,pmful + real(kind=kind_phys),intent(in),dimension(klon,klev):: plglac,plude,pdpmel + real(kind=kind_phys),intent(in),dimension(klon,klev):: pdmfup,pdmfdp + real(kind=kind_phys),intent(in),dimension(klon,klev):: pqen, ptenh,pqenh,pqsen + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptent,ptenq,pcte + +!--- local variables and arrays: + integer:: jk ,ik ,jl + real(kind=kind_phys):: zalv ,zzp + real(kind=kind_phys),dimension(klon,klev):: zdtdt,zdqdt,zdp + + !* 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)) + 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 * & + (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & + pmfds(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)*(pmfuq(jl,jk+1) - & + pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(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 * & + (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) + zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & + pmfdq(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 subroutines +!-------------------------------------------------------- + subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & + ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & + ptenv) + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + integer,intent(in):: klev,ktopm2 + integer,intent(in),dimension(klon):: ktype,kcbot,kctop + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfd,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pud,pvu,pvd + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenu,ptenv + +!--- local variables and arrays: + integer:: ik,ikb,jk,jl + + real(kind=kind_phys):: zzp,zdtdt + real(kind=kind_Phys),dimension(klon,klev):: zdudt,zdvdt,zdp + real(kind=kind_phys),dimension(klon,klev):: zuen,zven,zmfuu,zmfdu,zmfuv,zmfdv + +! + 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 subroutines +!-------------------------------------------------------- + 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 + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldflag + integer,intent(in):: kcall,kk,klev + + real(kind=kind_phys),intent(in),dimension(klon):: psp + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pt,pq + +!--- local variables and arrays: + integer:: jl,jk + integer:: isum + + real(kind=kind_phys)::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 + + return + end subroutine cuadjtqn +!--------------------------------------------------------- +! level 4 subroutines +!-------------------------------------------------------- + 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 +! ---------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + integer,intent(in):: kk,klev,klevm1 + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,pgeo,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: puen,pven ! not used. + real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pvu ! not used. + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh + +!--- output arguments: + integer,intent(out),dimension(klon):: ktype,kcbot + integer,intent(out),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(out),dimension(klon):: pmfub + real(kind=kind_phys),intent(out),dimension(klon,klev):: plrain + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,pqu,plu + real(kind=kind_phys),intent(out),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful + real(kind=kind_phys),intent(out),dimension(klon,klev):: pdmfup + +!--- local variables and arrays: + integer:: jl,klevp1 + real(kind=kind_phys):: 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 subroutines +!--------------------------------------------------------- + subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & + pgeoh,pmfu,pdmfen,pdmfde) + implicit none + +!--- input arguments: + logical,intent(in):: ldwork + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + + integer,intent(in):: klev,kk + integer,intent(in),dimension(klon):: kcbot + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh + +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(klon):: pdmfen + real(kind=kind_phys),intent(out),dimension(klon):: pdmfde + +!--- local variables and arrays: + logical:: llo1 + integer:: jl + real(kind=kind_phys):: zdz ,zmf + real(kind=kind_phys),dimension(klon):: zentr + + ! + !* 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(kind=kind_phys) 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(kind=kind_phys),intent(in):: tt + foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & + & /(rtwat-rtice))**2) + + return + end function foealfa + + real(kind=kind_phys) function foelhm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als + return + end function foelhm + + real(kind=kind_phys) function foeewm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foeewm = c2es * & + & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & + & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) + return + end function foeewm + + real(kind=kind_phys) function foedem(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & + & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) + return + end function foedem + + real(kind=kind_phys) function foeldcpm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + +!================================================================================================================= + end module cu_ntiedtke +!================================================================================================================= + diff --git a/phys/physics_mmm/module_libmassv.F90 b/phys/physics_mmm/module_libmassv.F90 new file mode 100644 index 0000000000..60ff9fa022 --- /dev/null +++ b/phys/physics_mmm/module_libmassv.F90 @@ -0,0 +1,91 @@ +!================================================================================================================= + module module_libmassv + + implicit none + + + interface vrec + module procedure vrec_d + module procedure vrec_s + end interface + + interface vsqrt + module procedure vsqrt_d + module procedure vsqrt_s + end interface + + integer, parameter, private :: R4KIND = selected_real_kind(6) + integer, parameter, private :: R8KIND = selected_real_kind(12) + + contains + + +!================================================================================================================= + subroutine vrec_d(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R8KIND),dimension(*),intent(in):: x + real(kind=R8KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=real(1.0,kind=R8KIND)/x(j) + enddo + + end subroutine vrec_d + +!================================================================================================================= + subroutine vrec_s(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R4KIND),dimension(*),intent(in):: x + real(kind=R4KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=real(1.0,kind=R4KIND)/x(j) + enddo + + end subroutine vrec_s + +!================================================================================================================= + subroutine vsqrt_d(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R8KIND),dimension(*),intent(in):: x + real(kind=R8KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=sqrt(x(j)) + enddo + + end subroutine vsqrt_d + +!================================================================================================================= + subroutine vsqrt_s(y,x,n) +!================================================================================================================= + + integer,intent(in):: n + real(kind=R4KIND),dimension(*),intent(in):: x + real(kind=R4KIND),dimension(*),intent(out):: y + + integer:: j + +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=sqrt(x(j)) + enddo + + end subroutine vsqrt_s + +!================================================================================================================= + end module module_libmassv +!================================================================================================================= diff --git a/phys/physics_mmm/mp_radar.F90 b/phys/physics_mmm/mp_radar.F90 new file mode 100644 index 0000000000..851e5d3f69 --- /dev/null +++ b/phys/physics_mmm/mp_radar.F90 @@ -0,0 +1,677 @@ +!================================================================================================================= + module mp_radar + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: radar_init, & + rayleigh_soak_wetgraupel + +!+---+-----------------------------------------------------------------+ +!..This set of routines facilitates computing radar reflectivity. +!.. This module is more library code whereas the individual microphysics +!.. schemes contains specific details needed for the final computation, +!.. so refer to location within each schemes calling the routine named +!.. rayleigh_soak_wetgraupel. +!.. The bulk of this code originated from Ulrich Blahak (Germany) and +!.. was adapted to WRF by G. Thompson. This version of code is only +!.. intended for use when Rayleigh scattering principles dominate and +!.. is not intended for wavelengths in which Mie scattering is a +!.. significant portion. Therefore, it is well-suited to use with +!.. 5 or 10 cm wavelength like USA NEXRAD radars. +!.. This code makes some rather simple assumptions about water +!.. coating on outside of frozen species (snow/graupel). Fraction of +!.. meltwater is simply the ratio of mixing ratio below melting level +!.. divided by mixing ratio at level just above highest T>0C. Also, +!.. immediately 90% of the melted water exists on the ice's surface +!.. and 10% is embedded within ice. No water is "shed" at all in these +!.. assumptions. The code is quite slow because it does the reflectivity +!.. calculations based on 50 individual size bins of the distributions. +!+---+-----------------------------------------------------------------+ + + integer, parameter, private :: R4KIND = selected_real_kind(6) + integer, parameter, private :: R8KIND = selected_real_kind(12) + + integer,parameter,public:: nrbins = 50 + integer,parameter,public:: slen = 20 + character(len=slen), public:: & + mixingrulestring_s, matrixstring_s, inclusionstring_s, & + hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & + mixingrulestring_g, matrixstring_g, inclusionstring_g, & + hoststring_g, hostmatrixstring_g, hostinclusionstring_g + + complex(kind=R8KIND),public:: m_w_0, m_i_0 + + 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 + + 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/) + + real(kind=kind_phys),public,dimension(4):: xcre,xcse,xcge,xcrg,xcsg,xcgg + real(kind=kind_phys),public:: xam_r,xbm_r,xmu_r,xobmr + real(kind=kind_phys),public:: xam_s,xbm_s,xmu_s,xoams,xobms,xocms + real(kind=kind_phys),public:: xam_g,xbm_g,xmu_g,xoamg,xobmg,xocmg + real(kind=kind_phys),public:: xorg2,xosg2,xogg2 + + +!..Single melting snow/graupel particle 90% meltwater on external sfc + character(len=256):: radar_debug + + double precision,parameter,public:: melt_outside_s = 0.9d0 + double precision,parameter,public:: melt_outside_g = 0.9d0 + + + contains + + +!================================================================================================================= + subroutine radar_init + implicit none +!================================================================================================================= + + integer:: n + +!----------------------------------------------------------------------------------------------------------------- + + pi5 = 3.14159*3.14159*3.14159*3.14159*3.14159 + lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar + m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) + m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) + k_w = (abs( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 + + do n = 1, nrbins+1 + simpson(n) = 0.0d0 + enddo + do n = 1, nrbins-1, 2 + simpson(n) = simpson(n) + basis(1) + simpson(n+1) = simpson(n+1) + basis(2) + simpson(n+2) = simpson(n+2) + basis(3) + enddo + + do n = 1, slen + mixingrulestring_s(n:n) = char(0) + matrixstring_s(n:n) = char(0) + inclusionstring_s(n:n) = char(0) + hoststring_s(n:n) = char(0) + hostmatrixstring_s(n:n) = char(0) + hostinclusionstring_s(n:n) = char(0) + mixingrulestring_g(n:n) = char(0) + matrixstring_g(n:n) = char(0) + inclusionstring_g(n:n) = char(0) + hoststring_g(n:n) = char(0) + hostmatrixstring_g(n:n) = char(0) + hostinclusionstring_g(n:n) = char(0) + enddo + + mixingrulestring_s = 'maxwellgarnett' + hoststring_s = 'air' + matrixstring_s = 'water' + inclusionstring_s = 'spheroidal' + hostmatrixstring_s = 'icewater' + hostinclusionstring_s = 'spheroidal' + + mixingrulestring_g = 'maxwellgarnett' + hoststring_g = 'air' + matrixstring_g = 'water' + inclusionstring_g = 'spheroidal' + hostmatrixstring_g = 'icewater' + hostinclusionstring_g = 'spheroidal' + +!..Create bins of snow (from 100 microns up to 2 cm). + xxdx(1) = 100.d-6 + xxdx(nrbins+1) = 0.02d0 + do n = 2, 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 + xxds(n) = dsqrt(xxdx(n)*xxdx(n+1)) + xdts(n) = xxdx(n+1) - xxdx(n) + enddo + +!..create bins of graupel (from 100 microns up to 5 cm). + xxdx(1) = 100.d-6 + xxdx(nrbins+1) = 0.05d0 + do n = 2, 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 + xxdg(n) = dsqrt(xxdx(n)*xxdx(n+1)) + xdtg(n) = xxdx(n+1) - xxdx(n) + enddo + + +!.. The calling program must set the m(D) relations and gamma shape +!.. parameter mu for rain, snow, and graupel. Easily add other types +!.. based on the template here. For majority of schemes with simpler +!.. exponential number distribution, mu=0. + + xcre(1) = 1. + xbm_r + xcre(2) = 1. + xmu_r + xcre(3) = 4. + xmu_r + xcre(4) = 7. + xmu_r + do n = 1, 4 + xcrg(n) = wgamma(xcre(n)) + enddo + xorg2 = 1./xcrg(2) + + xcse(1) = 1. + xbm_s + xcse(2) = 1. + xmu_s + xcse(3) = 4. + xmu_s + xcse(4) = 7. + xmu_s + do n = 1, 4 + xcsg(n) = wgamma(xcse(n)) + enddo + xosg2 = 1./xcsg(2) + + xcge(1) = 1. + xbm_g + xcge(2) = 1. + xmu_g + xcge(3) = 4. + xmu_g + xcge(4) = 7. + xmu_g + do n = 1, 4 + xcgg(n) = wgamma(xcge(n)) + enddo + xogg2 = 1./xcgg(2) + + xobmr = 1./xbm_r + xoams = 1./xam_s + xobms = 1./xbm_s + xocms = xoams**xobms + xoamg = 1./xam_g + xobmg = 1./xbm_g + xocmg = xoamg**xobmg + + end subroutine radar_init + +!================================================================================================================= + subroutine rayleigh_soak_wetgraupel(x_g,a_geo,b_geo,fmelt,meltratio_outside,m_w,m_i,lambda,c_back, & + mixingrule,matrix,inclusion,host,hostmatrix,hostinclusion) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*), intent(in):: mixingrule, matrix, inclusion, & + host, hostmatrix, hostinclusion + + complex(kind=R8KIND),intent(in):: m_w, m_i + + double precision, intent(in):: x_g, a_geo, b_geo, fmelt, lambda, meltratio_outside + +!--- output arguments: + double precision,intent(out):: c_back + +!--- local variables: + integer:: error + + complex(kind=R8KIND):: m_core, m_air + + double precision, parameter:: pix=3.1415926535897932384626434d0 + double precision:: d_large, d_g, rhog, x_w, xw_a, fm, fmgrenz, & + volg, vg, volair, volice, volwater, & + meltratio_outside_grenz, mra + +!----------------------------------------------------------------------------------------------------------------- + +!refractive index of air: + m_air = (1.0d0,0.0d0) + +!Limiting the degree of melting --- for safety: + fm = dmax1(dmin1(fmelt, 1.0d0), 0.0d0) +!Limiting the ratio of (melting on outside)/(melting on inside): + mra = dmax1(dmin1(meltratio_outside, 1.0d0), 0.0d0) + +!The relative portion of meltwater melting at outside should increase +!from the given input value (between 0 and 1) +!to 1 as the degree of melting approaches 1, +!so that the melting particle "converges" to a water drop. +!Simplest assumption is linear: + mra = mra + (1.0d0-mra)*fm + + x_w = x_g * fm + + d_g = a_geo * x_g**b_geo + + if(D_g .ge. 1d-12) then + + vg = PIx/6. * D_g**3 + rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0) + vg = x_g / rhog + + meltratio_outside_grenz = 1.0d0 - rhog / 1000. + + if (mra .le. meltratio_outside_grenz) then + !..In this case, it cannot happen that, during melting, all the + !.. air inclusions within the ice particle get filled with + !.. meltwater. This only happens at the end of all melting. + volg = vg * (1.0d0 - mra * fm) + + else + !..In this case, at some melting degree fm, all the air + !.. inclusions get filled with meltwater. + fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.) + + if (fm .le. fmgrenz) then + !.. not all air pockets are filled: + volg = (1.0 - mra * fm) * vg + else + !..all air pockets are filled with meltwater, now the + !.. entire ice sceleton melts homogeneously: + volg = (x_g - x_w) / 900.0 + x_w / 1000. + endif + + endif + + d_large = (6.0 / pix * volg) ** (1./3.) + volice = (x_g - x_w) / (volg * 900.0) + volwater = x_w / (1000. * volg) + volair = 1.0 - volice - volwater + + !..complex index of refraction for the ice-air-water mixture + !.. of the particle: + m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & + volwater, mixingrule, host, matrix, inclusion, & + hostmatrix, hostinclusion, error) + if (error .ne. 0) then + c_back = 0.0d0 + return + endif + + !..rayleigh-backscattering coefficient of melting particle: + c_back = (abs((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & + * pi5 * d_large**6 / lamda4 + + else + c_back = 0.0d0 + endif + + end subroutine rayleigh_soak_wetgraupel + +!================================================================================================================= + real(kind=kind_phys) function wgamma(y) + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: y + +!----------------------------------------------------------------------------------------------------------------- + + wgamma = exp(gammln(y)) + + end function wgamma + +!================================================================================================================= + real(kind=kind_phys) function gammln(xx) + implicit none +!(C) Copr. 1986-92 Numerical Recipes Software 2.02 +!================================================================================================================= + +!--- inout arguments: + real(kind=kind_phys),intent(in):: xx + +!--- local variables: + integer:: j + + double precision,parameter:: stp = 2.5066282746310005d0 + double precision,dimension(6), parameter:: & + cof = (/76.18009172947146d0, -86.50532032941677d0, & + 24.01409824083091d0, -1.231739572450155d0, & + .1208650973866179d-2, -.5395239384953d-5/) + double precision:: ser,tmp,x,y + +!----------------------------------------------------------------------------------------------------------------- + +!--- returns the value ln(gamma(xx)) for xx > 0. + x = xx + y = x + tmp = x+5.5d0 + tmp = (x+0.5d0)*log(tmp)-tmp + ser = 1.000000000190015d0 + do j = 1,6 + y=y+1.d0 + ser=ser+cof(j)/y + enddo + + gammln=tmp+log(stp*ser/x) + + end function gammln + +!================================================================================================================= + 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 +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: mixingrule, host, matrix, & + inclusion, hostmatrix, hostinclusion + + complex(kind=R8KIND),intent(in):: m_a, m_i, m_w + + double precision,intent(in):: volice, volair, volwater + +!--- output arguments: + integer,intent(out):: cumulerror + +!--- local variables: + integer:: error + + complex(kind=R8KIND):: mtmp + + double precision:: vol1, vol2 + +!----------------------------------------------------------------------------------------------------------------- + +!..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be air, ice, or water + cumulerror = 0 + get_m_mix_nested = cmplx(1.0d0,0.0d0) + + if (host .eq. 'air') then + if (matrix .eq. 'air') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volice / MAX(volice+volwater,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'air') then + get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & + volair, (1.0d0-volair), 0.0d0, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'icewater') then + get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & + volair, (1.0d0-volair), 0.0d0, mixingrule, & + 'ice', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'ice') then + + if (matrix .eq. 'ice') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volair / MAX(volair+volwater,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'ice') then + get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & + (1.0d0-volice), volice, 0.0d0, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'airwater') then + get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & + (1.0d0-volice), volice, 0.0d0, mixingrule, & + 'air', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'water') then + + if (matrix .eq. 'water') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volair / MAX(volice+volair,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'water') then + get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & + 0.0d0, (1.0d0-volwater), volwater, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'airice') then + get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & + 0.0d0, (1.0d0-volwater), volwater, mixingrule, & + 'ice', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'none') then + + get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & + volair, volice, volwater, mixingrule, & + matrix, inclusion, error) + cumulerror = cumulerror + error + + else + write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host +! call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + + if (cumulerror .ne. 0) then + write(radar_debug,*) 'get_m_mix_nested: error encountered' +! call physics_message(radar_debug) + get_m_mix_nested = cmplx(1.0d0,0.0d0) + endif + + end function get_m_mix_nested + +!================================================================================================================= + complex(kind=R8KIND) function get_m_mix (m_a, m_i, m_w, volair, volice, & + volwater, mixingrule, matrix, inclusion, & + error) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: mixingrule, matrix, inclusion + + complex(kind=R8KIND), intent(in):: m_a, m_i, m_w + + double precision, intent(in):: volice, volair, volwater + +!--- output arguments: + integer,intent(out):: error + +!----------------------------------------------------------------------------------------------------------------- + error = 0 + get_m_mix = cmplx(1.0d0,0.0d0) + + if (mixingrule .eq. 'maxwellgarnett') then + if (matrix .eq. 'ice') then + get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & + m_i, m_a, m_w, inclusion, error) + elseif (matrix .eq. 'water') then + get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & + m_w, m_a, m_i, inclusion, error) + elseif (matrix .eq. 'air') then + get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & + m_a, m_w, m_i, inclusion, error) + else + write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix +! call physics_message(radar_debug) + error = 1 + endif + + else + write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule +! call physics_message(radar_debug) + error = 2 + endif + + if (error .ne. 0) then + write(radar_debug,*) 'GET_M_MIX: error encountered' +! call physics_message(radar_debug) + endif + + end function get_m_mix + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, & + m1, m2, m3, inclusion, error) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: inclusion + + complex(kind=R8KIND),intent(in):: m1,m2,m3 + + double precision,intent(in):: vol1,vol2,vol3 + + +!--- output arguments: + integer,intent(out):: error + +!--- local variables: + complex(kind=R8KIND) :: beta2, beta3, m1t, m2t, m3t + +!----------------------------------------------------------------------------------------------------------------- + + error = 0 + + if (dabs(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then + write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & + 'partial volume fractions is not 1...ERROR' +! call physics_message(radar_debug) + m_complex_maxwellgarnett = CMPLX(-999.99d0,-999.99d0) + error = 1 + return + endif + + m1t = m1**2 + m2t = m2**2 + m3t = m3**2 + + if (inclusion .eq. 'spherical') then + beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) + beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) + elseif (inclusion .eq. 'spheroidal') then + beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) + beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) + else + write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', 'unknown inclusion: ', inclusion +! call physics_message(radar_debug) + m_complex_maxwellgarnett=cmplx(-999.99d0,-999.99d0,kind=R8KIND) + error = 1 + return + endif + + m_complex_maxwellgarnett = sqrt(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & + (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) + + end function m_complex_maxwellgarnett + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_water_ray(lambda,t) + implicit none +!================================================================================================================= + +!complex refractive Index of Water as function of Temperature T +![deg C] and radar wavelength lambda [m]; valid for +!lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C +!after Ray (1972) + +!--- input arguments: + double precision,intent(in):: t,lambda + +!--- local variables: + double precision,parameter:: pix=3.1415926535897932384626434d0 + double precision:: epsinf,epss,epsr,epsi + double precision:: alpha,lambdas,sigma,nenner + complex(kind=R8KIND),parameter:: i = (0d0,1d0) + +!----------------------------------------------------------------------------------------------------------------- + + epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T + epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & + + 1.190d-5 * (T - 25.0)*(T - 25.0) & + - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) + alpha = -16.8129d0/(T+273.16) + 0.0609265d0 + lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 + + nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) & + + (lambdas/lambda)**(2d0-2d0*alpha) + epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & + * sin(alpha*PIx*0.5)+1d0)) / nenner + epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & + * cos(alpha*PIx*0.5)+0d0)) / nenner & + + lambda*1.25664/1.88496 + + m_complex_water_ray = sqrt(cmplx(epsr,-epsi)) + + end function m_complex_water_ray + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_ice_maetzler(lambda,t) + implicit none +!================================================================================================================= + +!complex refractive index of ice as function of Temperature T +![deg C] and radar wavelength lambda [m]; valid for +!lambda in [0.0001,30] m; T in [-250.0,0.0] C +!Original comment from the Matlab-routine of Prof. Maetzler: +!Function for calculating the relative permittivity of pure ice in +!the microwave region, according to C. Maetzler, "Microwave +!properties of ice and snow", in B. Schmitt et al. (eds.) Solar +!System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer +!Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: +!TK = temperature (K), range 20 to 273.15 +!f = frequency in GHz, range 0.01 to 3000 + +!--- input arguments: + double precision,intent(in):: t,lambda + +!--- local variables: + double precision:: f,c,tk,b1,b2,b,deltabeta,betam,beta,theta,alfa + +!----------------------------------------------------------------------------------------------------------------- + + c = 2.99d8 + tk = t + 273.16 + f = c / lambda * 1d-9 + + b1 = 0.0207 + b2 = 1.16d-11 + b = 335.0d0 + deltabeta = exp(-10.02 + 0.0364*(tk-273.16)) + betam = (b1/tk) * ( exp(b/tk) / ((exp(b/tk)-1)**2) ) + b2*f*f + beta = betam + deltabeta + theta = 300. / tk - 1. + alfa = (0.00504d0 + 0.0062d0*theta) * exp(-22.1d0*theta) + m_complex_ice_maetzler = 3.1884 + 9.1e-4*(tk-273.16) + m_complex_ice_maetzler = m_complex_ice_maetzler & + + cmplx(0.0d0, (alfa/f + beta*f)) + m_complex_ice_maetzler = sqrt(conjg(m_complex_ice_maetzler)) + + end function m_complex_ice_maetzler + +!================================================================================================================= + end module mp_radar +!================================================================================================================= diff --git a/phys/physics_mmm/mp_wsm6.F90 b/phys/physics_mmm/mp_wsm6.F90 new file mode 100644 index 0000000000..ec2d1dca3c --- /dev/null +++ b/phys/physics_mmm/mp_wsm6.F90 @@ -0,0 +1,2449 @@ +!================================================================================================================= + module mp_wsm6 + use ccpp_kind_types,only: kind_phys + use module_libmassv,only: vrec,vsqrt + + use mp_radar + + implicit none + private + public:: mp_wsm6_run, & + mp_wsm6_init, & + mp_wsm6_finalize, & + refl10cm_wsm6 + + real(kind=kind_phys),parameter,private:: dtcldcr = 120. ! maximum time step for minor loops + real(kind=kind_phys),parameter,private:: n0r = 8.e6 ! intercept parameter rain +!real(kind=kind_phys),parameter,private:: n0g = 4.e6 ! intercept parameter graupel + real(kind=kind_phys),parameter,private:: avtr = 841.9 ! a constant for terminal velocity of rain + real(kind=kind_phys),parameter,private:: bvtr = 0.8 ! a constant for terminal velocity of rain + real(kind=kind_phys),parameter,private:: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + real(kind=kind_phys),parameter,private:: peaut = .55 ! collection efficiency + real(kind=kind_phys),parameter,private:: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + real(kind=kind_phys),parameter,private:: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + real(kind=kind_phys),parameter,private:: avts = 11.72 ! a constant for terminal velocity of snow + real(kind=kind_phys),parameter,private:: bvts = .41 ! a constant for terminal velocity of snow +!real(kind=kind_phys),parameter,private:: avtg = 330. ! a constant for terminal velocity of graupel +!real(kind=kind_phys),parameter,private:: bvtg = 0.8 ! a constant for terminal velocity of graupel +!real(kind=kind_phys),parameter,private:: deng = 500. ! density of graupel ! set later with hail_opt + real(kind=kind_phys),parameter,private:: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain + real(kind=kind_phys),parameter,private:: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow +!real(kind=kind_phys),parameter,private:: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel + real(kind=kind_phys),parameter,private:: dicon = 11.9 ! constant for the cloud-ice diamter + real(kind=kind_phys),parameter,private:: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real(kind=kind_phys),parameter,private:: pfrz1 = 100. ! constant in Biggs freezing + real(kind=kind_phys),parameter,private:: pfrz2 = 0.66 ! constant in Biggs freezing + real(kind=kind_phys),parameter,private:: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg + real(kind=kind_phys),parameter,private:: eacrc = 1.0 ! Snow/cloud-water collection efficiency + real(kind=kind_phys),parameter,private:: dens = 100.0 ! Density of snow + real(kind=kind_phys),parameter,private:: qs0 = 6.e-4 ! threshold amount for aggretion to occur + + real(kind=kind_phys),parameter,public :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) + real(kind=kind_phys),parameter,public :: n0s = 2.e6 ! temperature dependent intercept parameter snow + real(kind=kind_phys),parameter,public :: alpha = .12 ! .122 exponen factor for n0s + + real(kind=kind_phys),save:: & + qc0,qck1, & + 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, & + 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 + + real(kind=kind_phys),public,save:: pidn0s,pidnc + + + contains + + +!================================================================================================================= +!>\section arg_table_mp_wsm6_init +!!\html\include mp_wsm6_init.html +!! + subroutine mp_wsm6_init(den0,denr,dens,cl,cpv,hail_opt,errmsg,errflg) +!================================================================================================================= + +!input arguments: + integer,intent(in):: hail_opt ! RAS + real(kind=kind_phys),intent(in):: den0,denr,dens,cl,cpv + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + +! 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 + +!+---+-----------------------------------------------------------------+ +!.. 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 + + errmsg = 'mp_wsm6_init OK' + errflg = 0 + + end subroutine mp_wsm6_init + +!================================================================================================================= +!>\section arg_table_mp_wsm6_finalize +!!\html\include mp_wsm6_finalize.html +!! + subroutine mp_wsm6_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_finalize OK' + errflg = 0 + + end subroutine mp_wsm6_finalize + +!================================================================================================================= +!>\section arg_table_mp_wsm6_run +!!\html\include mp_wsm6_run.html +!! + subroutine mp_wsm6_run(t,q,qc,qi,qr,qs,qg,den,p,delz,delt, & + g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin,xls, & + xlv0,xlf0,den0,denr,cliq,cice,psat, & + rain,rainncv,sr,snow,snowncv,graupel, & + graupelncv,rainprod2d,evapprod2d, & + its,ite,kts,kte,errmsg,errflg & + ) +!=================================================================================================================! +! 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. +! + +!input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:,:):: & + den, & + p, & + delz + real(kind=kind_phys),intent(in):: & + delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + xls, & + xlv0, & + xlf0, & + cliq, & + cice, & + psat, & + denr + +!inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:,:):: & + t + real(kind=kind_phys),intent(inout),dimension(its:,:):: & + q, & + qc, & + qi, & + qr, & + qs, & + qg + real(kind=kind_phys),intent(inout),dimension(its:):: & + rain, & + rainncv, & + sr + + real(kind=kind_phys),intent(inout),dimension(its:),optional:: & + snow, & + snowncv + + real(kind=kind_phys),intent(inout),dimension(its:),optional:: & + graupel, & + graupelncv + + real(kind=kind_phys),intent(inout),dimension(its:,:),optional:: & + rainprod2d, & + evapprod2d + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!local variables and arrays: + real(kind=kind_phys),dimension(its:ite,kts:kte,3):: & + rh, & + qsat, & + rslope, & + rslope2, & + rslope3, & + rslopeb, & + qrs_tmp, & + falk, & + fall, & + work1 + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + fallc, & + falkc, & + work1c, & + work2c, & + workr, & + worka + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + den_tmp, & + delz_tmp + real(kind=kind_phys),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(kind=kind_phys),dimension(its:ite,kts:kte):: & + qsum, & + xl, & + cpm, & + work2, & + denfac, & + xni, & + denqrs1, & + denqrs2, & + denqrs3, & + denqci, & + n0sfac + real(kind=kind_phys),dimension(its:ite):: & + delqrs1, & + delqrs2, & + delqrs3, & + delqi + real(kind=kind_phys),dimension(its:ite):: & + tstepsnow, & + tstepgraup + integer,dimension(its:ite):: & + mstep, & + numdt + logical,dimension(its:ite):: flgcld + real(kind=kind_phys):: & + 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(kind=kind_phys):: vt2ave + real(kind=kind_phys):: holdc, holdci + integer:: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim + +!Temporaries used for inlining fpvs function + real(kind=kind_phys):: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp + +! variables for optimization + real(kind=kind_phys),dimension(its:ite):: dvec1,tvec1 + real(kind=kind_phys):: 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 + qc(i,k) = max(qc(i,k),0.0) + qr(i,k) = max(qr(i,k),0.0) + qi(i,k) = max(qi(i,k),0.0) + qs(i,k) = max(qs(i,k),0.0) + qg(i,k) = max(qg(i,k),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) = 0. + if(present(graupelncv) .and. present(graupel)) graupelncv(i) = 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 + do i = its,ite + dvec1(i) = den(i,k) + enddo + call vrec(tvec1,dvec1,ite-its+1) + do i = its, ite + tvec1(i) = tvec1(i)*den0 + enddo + call vsqrt(dvec1,tvec1,ite-its+1) + do i = its,ite + denfac(i,k) = dvec1(i) + enddo + enddo +! +! Inline expansion for fpvs +! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qsat(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) + qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) + qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) + qsat(i,k,1) = max(qsat(i,k,1),qmin) + rh(i,k,1) = max(q(i,k) / qsat(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) + qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) + qsat(i,k,2) = max(qsat(i,k,2),qmin) + rh(i,k,2) = max(q(i,k) / qsat(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(qi(i,k),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) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + 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( (qs(i,k)+qg(i,k)), 1.E-15) + if( qsum(i,k) .gt. 1.e-15 ) then + worka(i,k) = (work1(i,k,2)*qs(i,k) + work1(i,k,3)*qg(i,k)) & + / qsum(i,k) + else + worka(i,k) = 0. + endif + denqrs1(i,k) = den(i,k)*qr(i,k) + denqrs2(i,k) = den(i,k)*qs(i,k) + denqrs3(i,k) = den(i,k)*qg(i,k) + if(qr(i,k).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 + qr(i,k) = max(denqrs1(i,k)/den(i,k),0.) + qs(i,k) = max(denqrs2(i,k)/den(i,k),0.) + qg(i,k) = 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) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + 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(qs(i,k).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), & + -qs(i,k)/mstep(i)),0.) + qs(i,k) = qs(i,k) + psmlt(i,k) + qr(i,k) = qr(i,k) - 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(qg(i,k).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), & + -qg(i,k)/mstep(i)),0.) + qg(i,k) = qg(i,k) + pgmlt(i,k) + qr(i,k) = qr(i,k) - 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(qi(i,k).le.0.) then + work1c(i,k) = 0. + else + xmi = den(i,k)*qi(i,k)/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)*qi(i,k) + 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 + qi(i,k) = 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) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & + + snowncv(i) + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + 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) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & + + graupelncv(i) + graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) + endif + endif + if(present (snowncv)) then + if(fallsum.gt.0.)sr(i)=(snowncv(i) + graupelncv(i))/(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.qi(i,k).gt.0.) then + qc(i,k) = qc(i,k) + qi(i,k) + t(i,k) = t(i,k) - xlf/cpm(i,k)*qi(i,k) + qi(i,k) = 0. + endif +!--------------------------------------------------------------- +! pihmf: homogeneous freezing of cloud water below -40c [HL A45] +! (T<-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.40..and.qc(i,k).gt.0.) then + qi(i,k) = qi(i,k) + qc(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*qc(i,k) + qc(i,k) = 0. + endif +!--------------------------------------------------------------- +! pihtf: heterogeneous freezing of cloud water [HL A44] +! (T0>T>-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qc(i,k).gt.qmin) then +! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & +! * den(i,k)/denr/xncr*qc(i,k)**2*dtcld,qc(i,k)) + supcolt=min(supcol,50.) + pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & + * den(i,k)/denr/xncr*qc(i,k)*qc(i,k)*dtcld,qc(i,k)) + qi(i,k) = qi(i,k) + pfrzdtc + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc + qc(i,k) = qc(i,k)-pfrzdtc + endif +!--------------------------------------------------------------- +! pgfrz: freezing of rain water [HL A20] [LFO 45] +! (TG) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qr(i,k).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,qr(i,k)) + 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, & + qr(i,k)) + qg(i,k) = qg(i,k) + pfrzdtr + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr + qr(i,k) = qr(i,k)-pfrzdtr + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! update the slope parameters for microphysics computation +! + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + 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),qsat(i,k,1)) + work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qsat(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)-qsat(i,k,1) + satdt = supsat/dtcld +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qc(i,k).gt.qc0) then + praut(i,k) = qck1*qc(i,k)**(7./3.) + praut(i,k) = min(praut(i,k),qc(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [LFO 51] +! (C->R) +!--------------------------------------------------------------- + if(qr(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qr(i,k).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),-qr(i,k)/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)-qsat(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(qi(i,k),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qi(i,k),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)*qi(i,k)/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( (qs(i,k)+qg(i,k)), 1.E-15) + if(qsum(i,k) .gt. 1.e-15) then + vt2ave=(vt2s*qs(i,k)+vt2g*qg(i,k))/(qsum(i,k)) + else + vt2ave=0. + endif + if(supcol.gt.0.and.qi(i,k).gt.qmin) then + if(qr(i,k).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*qi(i,k)*n0r*abs(vt2r-vt2i)*acrfac/4. +! reduce collection efficiency (suggested by B. Wilt) + praci(i,k) = praci(i,k)*min(max(0.0,qr(i,k)/qi(i,k)),1.)**2 + praci(i,k) = min(praci(i,k),qi(i,k)/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) +! reduce collection efficiency (suggested by B. Wilt) + piacr(i,k) = piacr(i,k)*min(max(0.0,qi(i,k)/qr(i,k)),1.)**2 + piacr(i,k) = min(piacr(i,k),qr(i,k)/dtcld) + endif +!------------------------------------------------------------- +! psaci: accretion of cloud ice by snow [HDC 10] +! (TS) +!------------------------------------------------------------- + if(qs(i,k).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*qi(i,k)*eacrs*n0s*n0sfac(i,k) & + * abs(vt2ave-vt2i)*acrfac/4. + psaci(i,k) = min(psaci(i,k),qi(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgaci: accretion of cloud ice by graupel [HL A17] [LFO 41] +! (TG) +!------------------------------------------------------------- + if(qg(i,k).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*qi(i,k)*n0g*abs(vt2ave-vt2i)*acrfac/4. + pgaci(i,k) = min(pgaci(i,k),qi(i,k)/dtcld) + endif + endif +!------------------------------------------------------------- +! psacw: accretion of cloud water by snow [HL A7] [LFO 24] +! (TS, and T>=T0: C->R) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & +! reduce collection efficiency (suggested by B. Wilt) + * min(max(0.0,qs(i,k)/qc(i,k)),1.)**2 & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgacw: accretion of cloud water by graupel [HL A6] [LFO 40] +! (TG, and T>=T0: C->R) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & +! reduce collection efficiency (suggested by B. Wilt) + * min(max(0.0,qg(i,k)/qc(i,k)),1.)**2 & + * qc(i,k)*denfac(i,k),qc(i,k)/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) = (qs(i,k)*psacw(i,k)+qg(i,k)*pgacw(i,k)) & + /(qsum(i,k)) + endif +!------------------------------------------------------------- +! pracs: accretion of snow by rain [HL A11] [LFO 27] +! (TG) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin.and.qr(i,k).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 +! reduce collection efficiency (suggested by B. Wilt) + pracs(i,k) = pracs(i,k)*min(max(0.0,qr(i,k)/qs(i,k)),1.)**2 + pracs(i,k) = min(pracs(i,k),qs(i,k)/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 +! reduce collection efficiency (suggested by B. Wilt) + psacr(i,k) = psacr(i,k)*min(max(0.0,qs(i,k)/qr(i,k)),1.)**2 + psacr(i,k) = min(psacr(i,k),qr(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgacr: accretion of rain by graupel [HL A12] [LFO 42] +! (TG) (T>=T0: enhance melting of graupel) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qr(i,k).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 +! reduce collection efficiency (suggested by B. Wilt) + pgacr(i,k) = pgacr(i,k)*min(max(0.0,qg(i,k)/qr(i,k)),1.)**2 + pgacr(i,k) = min(pgacr(i,k),qr(i,k)/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(qg(i,k).gt.qcrmin.and.qs(i,k).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(qs(i,k).gt.0.) & + pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & + / xlf,-qs(i,k)/dtcld),0.) +!------------------------------------------------------------- +! pgeml: enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] +! (T>=T0: G->R) +!------------------------------------------------------------- + if(qg(i,k).gt.0.) & + pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & + / xlf,-qg(i,k)/dtcld),0.) + endif + if(supcol.gt.0) then +!------------------------------------------------------------- +! pidep: deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qi(i,k).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),-qi(i,k)/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(qs(i,k).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),-qs(i,k)/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(qg(i,k).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),-qg(i,k)/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(qi(i,k),0.))/dtcld) + pigen(i,k) = min(min(pigen(i,k),satdt),supice) + endif +! +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qi(i,k).gt.0.) then + qimax = roqimax/den(i,k) + psaut(i,k) = max(0.,(qi(i,k)-qimax)/dtcld) + endif +! +!------------------------------------------------------------- +! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] +! (TG) +!------------------------------------------------------------- + if(qs(i,k).gt.0.) then + alpha2 = 1.e-3*exp(0.09*(-supcol)) + pgaut(i,k) = min(max(0.,alpha2*(qs(i,k)-qs0)),qs(i,k)/dtcld) + endif + endif +! +!------------------------------------------------------------- +! psevp: evaporation of melting snow [HL A35] [RH83 A27] +! (T>=T0: S->V) +!------------------------------------------------------------- + if(supcol.lt.0.) then + if(qs(i,k).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),-qs(i,k)/dtcld),0.) + endif +!------------------------------------------------------------- +! pgevp: evaporation of melting graupel [HL A25] [RH84 A19] +! (T>=T0: G->V) +!------------------------------------------------------------- + if(qg(i,k).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),-qg(i,k)/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(qr(i,k).lt.1.e-4.and.qs(i,k).lt.1.e-4) delta2=1. + if(qr(i,k).lt.1.e-4) delta3=1. + if(t(i,k).le.t0c) then +! +! cloud water +! + value = max(qmin,qc(i,k)) + 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,qi(i,k)) + 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,qr(i,k)) + 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,qs(i,k)) + 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,qg(i,k)) + 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 + qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & + + paacw(i,k)+paacw(i,k))*dtcld,0.) + qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & + + prevp(i,k)-piacr(i,k)-pgacr(i,k) & + - psacr(i,k))*dtcld,0.) + qi(i,k) = max(qi(i,k)-(psaut(i,k)+praci(i,k) & + + psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & + * dtcld,0.) + qs(i,k) = max(qs(i,k)+(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.) + qg(i,k) = max(qg(i,k)+(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,qc(i,k)) + 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,qr(i,k)) + 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,qs(i,k)) + 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,qg(i,k)) + 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 + qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & + + paacw(i,k)+paacw(i,k))*dtcld,0.) + qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & + + prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & + - pgeml(i,k))*dtcld,0.) + qs(i,k) = max(qs(i,k)+(psevp(i,k)-pgacs(i,k) & + + pseml(i,k))*dtcld,0.) + qg(i,k) = max(qg(i,k)+(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 +! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qsat(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) + qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) + qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) + qsat(i,k,1) = max(qsat(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) + qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) + qsat(i,k,2) = max(qsat(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),qsat(i,k,1),xl(i,k),cpm(i,k)) + work2(i,k) = qc(i,k)+work1(i,k,1) + pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) + if(qc(i,k).gt.0..and.work1(i,k,1).lt.0.) & + pcond(i,k) = max(work1(i,k,1),-qc(i,k))/dtcld + q(i,k) = q(i,k)-pcond(i,k)*dtcld + qc(i,k) = max(qc(i,k)+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(qc(i,k).le.qmin) qc(i,k) = 0.0 + if(qi(i,k).le.qmin) qi(i,k) = 0.0 + enddo + enddo + enddo ! big loops + + if(present(rainprod2d) .and. present(evapprod2d)) then + do k = kts, kte + do i = its,ite + rainprod2d(i,k) = praut(i,k)+pracw(i,k)+praci(i,k)+psaci(i,k)+pgaci(i,k) & + + psacw(i,k)+pgacw(i,k)+paacw(i,k)+psaut(i,k) + evapprod2d(i,k) = -(prevp(i,k)+psevp(i,k)+pgevp(i,k)+psdep(i,k)+pgdep(i,k)) + enddo + enddo + endif +! +!---------------------------------------------------------------- +! CCPP checks: +! + + errmsg = 'mp_wsm6_run OK' + errflg = 0 + + end subroutine mp_wsm6_run + +!================================================================================================================= + real(kind=kind_phys) function rgmma(x) +!================================================================================================================= +!rgmma function: use infinite product form + + real(kind=kind_phys),intent(in):: x + + integer:: i + real(kind=kind_phys),parameter:: euler=0.577215664901532 + real(kind=kind_phys):: y + +!----------------------------------------------------------------------------------------------------------------- + + 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(kind=kind_phys) function fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!================================================================================================================= + + integer,intent(in):: ice + real(kind=kind_phys),intent(in):: cice,cliq,cvap,hsub,hvap,psat,rd,rv,t0c + real(kind=kind_phys),intent(in):: t + + real(kind=kind_phys):: tr,ttp,dldt,dldti,xa,xb,xai,xbi + +!----------------------------------------------------------------------------------------------------------------- + + 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 slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: den,denfac,t + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte,3):: qrs + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte,3):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdar,lamdas,lamdag,x,y,z,supcol + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!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) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdar,x,y + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!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) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdas,x,y,z,supcol + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!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) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdag,x,y + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!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 +! + +!--- input arguments: + integer,intent(in):: im,km,id,iter + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(im):: precip + real(kind=kind_phys),intent(inout),dimension(im,km):: rql,wwl + +!---- local variables and arrays: + integer:: i,k,n,m,kk,kb,kt + real(kind=kind_phys):: tl,tl2,qql,dql,qqd + real(kind=kind_phys):: th,th2,qqh,dqh + real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl + real(kind=kind_phys),dimension(km):: dz,ww,qq,wd,wa,was + real(kind=kind_phys),dimension(km):: den,denfac,tk + real(kind=kind_phys),dimension(km):: qn,qr,tmp,tmp1,tmp2,tmp3 + real(kind=kind_phys),dimension(km+1):: wi,zi,za + real(kind=kind_phys),dimension(km+1):: dza,qa,qmi,qpi + +!----------------------------------------------------------------------------------------------------------------- + + 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 +! + +!--- input arguments: + integer,intent(in):: im,km,id,iter + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(im):: precip1,precip2 + real(kind=kind_phys),intent(inout),dimension(im,km):: rql,rql2,wwl + +!---- local variables and arrays: + integer:: i,ist,k,n,m,kk,kb,kt + real(kind=kind_phys):: tl,tl2,qql,dql,qqd + real(kind=kind_phys):: th,th2,qqh,dqh + real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl + real(kind=kind_phys),dimension(km):: dz,ww,qq,qq2,wd,wa,wa2,was + real(kind=kind_phys),dimension(km):: den,denfac,tk + real(kind=kind_phys),dimension(km):: qn,qr,qr2,tmp,tmp1,tmp2,tmp3 + real(kind=kind_phys),dimension(km+1):: wi,zi,za + real(kind=kind_phys),dimension(km+1):: dza,qa,qa2,qmi,qpi + real(kind=kind_phys),dimension(im):: precip + +!----------------------------------------------------------------------------------------------------------------- + + 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) + implicit none +!================================================================================================================= + +!..Sub arguments + integer,intent(in):: kts,kte + real(kind=kind_phys),intent(in),dimension(kts:kte):: qv1d,qr1d,qs1d,qg1d,t1d,p1d + real(kind=kind_phys),intent(inout),dimension(kts:kte):: dBz + +!..Local variables + logical:: melti + logical,dimension(kts:kte):: l_qr,l_qs,l_qg + + INTEGER:: i,k,k_0,kbot,n + + real(kind=kind_phys),parameter:: R=287. + real(kind=kind_phys):: temp_c + real(kind=kind_phys),dimension(kts:kte):: temp,pres,qv,rho + real(kind=kind_phys),dimension(kts:kte):: rr,rs,rg + real(kind=kind_phys),dimension(kts:kte):: ze_rain,ze_snow,ze_graupel + + double precision:: fmelt_s,fmelt_g + double precision:: cback,x,eta,f_d + double precision,dimension(kts:kte):: ilamr,ilams,ilamg + double precision,dimension(kts:kte):: n0_r, n0_s, n0_g + double precision:: lamr,lams,lamg + +!----------------------------------------------------------------------------------------------------------------- + + do k = kts, kte + dBZ(k) = -35.0 + enddo + +!+---+-----------------------------------------------------------------+ +!..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)) + + 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 + + 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 + + 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 + +!+---+-----------------------------------------------------------------+ +!..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 + +!+---+-----------------------------------------------------------------+ +!..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. +!+---+-----------------------------------------------------------------+ + + 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 + + +!+---+-----------------------------------------------------------------+ +!..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). +!+---+-----------------------------------------------------------------+ + + if (melti .and. k_0.ge.kts+1) then + do k = k_0-1, kts, -1 + +!..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 + + +!..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 + + 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 + + +!================================================================================================================= + end module mp_wsm6 +!================================================================================================================= diff --git a/phys/physics_mmm/mp_wsm6_effectRad.F90 b/phys/physics_mmm/mp_wsm6_effectRad.F90 new file mode 100644 index 0000000000..458bbda34a --- /dev/null +++ b/phys/physics_mmm/mp_wsm6_effectRad.F90 @@ -0,0 +1,197 @@ +!================================================================================================================= + module mp_wsm6_effectrad + use ccpp_kind_types,only: kind_phys + + + use mp_wsm6,only: alpha,n0s,n0smax,pidn0s,pidnc + + + implicit none + private + public:: mp_wsm6_effectRad_run, & + mp_wsm6_effectrad_init, & + mp_wsm6_effectRad_finalize + + + contains + + +!================================================================================================================= +!>\section arg_table_mp_wsm6_effectRad_init +!!\html\include mp_wsm6_effectRad_init.html +!! + subroutine mp_wsm6_effectRad_init(errmsg,errflg) +!================================================================================================================= + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_effectRad_init OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_init + +!================================================================================================================= +!>\section arg_table_mp_wsm6_effectRad_finalize +!!\html\include mp_wsm6_effectRad_finalize.html +!! + subroutine mp_wsm6_effectRad_finalize(errmsg,errflg) +!================================================================================================================= + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_effectRad_final OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_finalize + +!================================================================================================================= +!>\section arg_table_mp_wsm6_effectRad_run +!!\html\include mp_wsm6_effectRad_run.html +!! + subroutine mp_wsm6_effectRad_run(do_microp_re,t,qc,qi,qs,rho,qmin,t0c,re_qc_bg,re_qi_bg,re_qs_bg, & + re_qc_max,re_qi_max,re_qs_max,re_qc,re_qi,re_qs,its,ite,kts,kte, & + errmsg,errflg) +!================================================================================================================= +! 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. +!----------------------------------------------------------------------------------------------------------------- + + +!..Sub arguments + logical,intent(in):: do_microp_re + integer,intent(in):: its,ite,kts,kte + real(kind=kind_phys),intent(in):: qmin + real(kind=kind_phys),intent(in):: t0c + real(kind=kind_phys),intent(in):: re_qc_bg,re_qi_bg,re_qs_bg + real(kind=kind_phys),intent(in):: re_qc_max,re_qi_max,re_qs_max + real(kind=kind_phys),dimension(its:,:),intent(in):: t + real(kind=kind_phys),dimension(its:,:),intent(in):: qc + real(kind=kind_phys),dimension(its:,:),intent(in):: qi + real(kind=kind_phys),dimension(its:,:),intent(in):: qs + real(kind=kind_phys),dimension(its:,:),intent(in):: rho + real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qc + real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qi + real(kind=kind_phys),dimension(its:,:),intent(inout):: re_qs + +!...Output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!..Local variables + integer:: i,k + integer:: inu_c + real(kind=kind_phys),dimension(its:ite,kts:kte):: ni + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqc + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqi + real(kind=kind_phys),dimension(its:ite,kts:kte):: rni + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqs + real(kind=kind_phys):: temp + real(kind=kind_phys):: lamdac + real(kind=kind_phys):: supcol,n0sfac,lamdas + real(kind=kind_phys):: diai ! diameter of ice in m + logical:: has_qc, has_qi, has_qs +!..Minimum microphys values + real(kind=kind_phys),parameter:: R1 = 1.E-12 + real(kind=kind_phys),parameter:: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real(kind=kind_phys),parameter:: bm_r = 3.0 + real(kind=kind_phys),parameter:: obmr = 1.0/bm_r + real(kind=kind_phys),parameter:: nc0 = 3.E8 + +!----------------------------------------------------------------------------------------------------------------- + + if(.not. do_microp_re) return + +!--- initialization of effective radii of cloud water, cloud ice, and snow to background values: + do k = kts,kte + do i = its,ite + re_qc(i,k) = re_qc_bg + re_qi(i,k) = re_qi_bg + re_qs(i,k) = re_qs_bg + enddo + enddo + +!--- computation of effective radii: + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts,kte + do i = its,ite + ! for cloud + rqc(i,k) = max(R1,qc(i,k)*rho(i,k)) + if (rqc(i,k).gt.R1) has_qc = .true. + ! for ice + rqi(i,k) = max(R1,qi(i,k)*rho(i,k)) + temp = (rho(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(i,k)= max(R2,ni(i,k)*rho(i,k)) + if (rqi(i,k).gt.R1 .and. rni(i,k).gt.R2) has_qi = .true. + ! for snow + rqs(i,k) = max(R1,qs(i,k)*rho(i,k)) + if (rqs(i,k).gt.R1) has_qs = .true. + enddo + enddo + + if (has_qc) then + do k = kts,kte + do i = its,ite + if (rqc(i,k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(i,k))**obmr + re_qc(i,k) = max(2.51E-6,min(1.5*(1.0/lamdac),re_qc_max)) + enddo + enddo + endif + + if (has_qi) then + do k = kts,kte + do i = its,ite + if (rqi(i,k).le.R1 .or. rni(i,k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(i,k)/ni(i,k)) + re_qi(i,k) = max(10.01E-6,min(0.75*0.163*diai,re_qi_max)) + enddo + enddo + endif + + if (has_qs) then + do i = its,ite + do k = kts,kte + if (rqs(i,k).le.R1) CYCLE + supcol = t0c-t(i,k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(i,k))) + re_qs(i,k) = max(25.E-6,min(0.5*(1./lamdas),re_qs_max)) + enddo + enddo + endif + +!--- limit effective radii of cloud water, cloud ice, and snow to maximum values: + do k = kts,kte + do i = its,ite + re_qc(i,k) = max(re_qc_bg,min(re_qc(i,k),re_qc_max)) + re_qi(i,k) = max(re_qi_bg,min(re_qi(i,k),re_qi_max)) + re_qs(i,k) = max(re_qs_bg,min(re_qs(i,k),re_qs_max)) + enddo + enddo + + errmsg = 'mp_wsm6_effectRad_run OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_run + +!================================================================================================================= + end module mp_wsm6_effectrad +!================================================================================================================= diff --git a/phys/physics_mmm/sf_sfclayrev.F90 b/phys/physics_mmm/sf_sfclayrev.F90 new file mode 100644 index 0000000000..d05ff3e45a --- /dev/null +++ b/phys/physics_mmm/sf_sfclayrev.F90 @@ -0,0 +1,1119 @@ +!================================================================================================================= + module sf_sfclayrev + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: sf_sfclayrev_run, & + sf_sfclayrev_init, & + sf_sfclayrev_finalize + + + real(kind=kind_phys),parameter:: vconvc= 1. + real(kind=kind_phys),parameter:: czo = 0.0185 + real(kind=kind_phys),parameter:: ozo = 1.59e-5 + + real(kind=kind_phys),dimension(0:1000 ),save:: psim_stab,psim_unstab,psih_stab,psih_unstab + + + contains + + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_init +!!\html\include sf_sfclayrev_init.html +!! + subroutine sf_sfclayrev_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!local variables: + integer:: n + real(kind=kind_phys):: zolf + +!----------------------------------------------------------------------------------------------------------------- + + do n = 0,1000 +! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + +! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + enddo + + errmsg = 'sf_sfclayrev_init OK' + errflg = 0 + + end subroutine sf_sfclayrev_init + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_finalize +!!\html\include sf_sfclayrev_finalize.html +!! + subroutine sf_sfclayrev_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'sf_sfclayrev_finalize OK' + errflg = 0 + + end subroutine sf_sfclayrev_finalize + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_run +!!\html\include sf_sfclayrev_run.html +!! + subroutine sf_sfclayrev_run(ux,vx,t1d,qv1d,p1d,dz8w1d, & + cp,g,rovcp,r,xlv,psfcpa,chs,chs2,cqs2, & + cpm,pblh,rmol,znt,ust,mavail,zol,mol, & + regime,psim,psih,fm,fh, & + xland,hfx,qfx,tsk, & + u10,v10,th2,t2,q2,flhc,flqc,qgh, & + qsfc,lh,gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,p1000mb,lakemask, & + shalwater_z0,water_depth, & + isftcflx,iz0tlnd,scm_force_flux, & + ustm,ck,cka,cd,cda, & + its,ite,errmsg,errflg & + ) +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: isfflx + logical,intent(in):: shalwater_z0 + logical,intent(in),optional:: scm_force_flux + + integer,intent(in):: its,ite + integer,intent(in),optional:: isftcflx, iz0tlnd + + 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(its:):: & + mavail, & + pblh, & + psfcpa, & + tsk, & + xland, & + lakemask, & + water_depth + + real(kind=kind_phys),intent(in),dimension(its:):: & + dx, & + dz8w1d, & + ux, & + vx, & + qv1d, & + p1d, & + t1d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:):: & + lh, & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(its:),optional:: & + ck, & + cka, & + cd, & + cda + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:):: & + 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(its:),optional:: & + ustm + +!--- local variables: + integer:: n,i,k,kk,l,nzol,nk,nzol2,nzol10 + + real(kind=kind_phys),parameter:: xka = 2.4e-5 + real(kind=kind_phys),parameter:: prt = 1. + real(kind=kind_phys),parameter:: salinity_factor = 0.98 + + real(kind=kind_phys):: pl,thcon,tvcon,e1 + real(kind=kind_phys):: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 + real(kind=kind_phys):: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 + real(kind=kind_phys):: fluxc,vsgd,z0q,visc,restar,czil,gz0ozq,gz0ozt + real(kind=kind_phys):: zw,zn1,zn2 + real(kind=kind_phys):: zolzz,zol0 + real(kind=kind_phys):: zl2,zl10,z0t + + real(kind=kind_phys),dimension(its:ite):: & + za, & + thvx, & + zqkl, & + zqklp1, & + thx, & + qx, & + psih2, & + psim2, & + psih10, & + psim10, & + denomq, & + denomq2, & + denomt2, & + wspdi, & + gz2oz0, & + gz10oz0, & + rhox, & + govrth, & + tgdsa, & + scr3, & + scr4, & + thgb, & + psfc + + real(kind=kind_phys),dimension(its:ite):: & + pq, & + pq2, & + pq10 + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite +!PSFC cb + psfc(i)=psfcpa(i)/1000. + enddo +! +!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: +! + do 5 i = its,ite + tgdsa(i)=tsk(i) +!PSFC cb +! thgb(i)=tsk(i)*(100./psfc(i))**rovcp + thgb(i)=tsk(i)*(p1000mb/psfcpa(i))**rovcp + 5 continue +! +!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., +! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. +! +! *** NOTE *** +! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, +! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE +! TENDENCIES. +! + 10 continue + +!do 24 i = its,ite +! ux(i)=u1d(i) +! vx(i)=v1d(i) +!24 continue + + 26 continue + +!.....SCR3(I,K) STORE TEMPERATURE, +! SCR4(I,K) STORE VIRTUAL TEMPERATURE. + + do 30 i = its,ite +!PL cb + pl=p1d(i)/1000. + scr3(i)=t1d(i) +! thcon=(100./pl)**rovcp + thcon=(p1000mb*0.001/pl)**rovcp + thx(i)=scr3(i)*thcon + scr4(i)=scr3(i) + thvx(i)=thx(i) + qx(i)=0. + 30 continue +! + do i = its,ite + qgh(i)=0. + flhc(i)=0. + flqc(i)=0. + cpm(i)=cp + enddo +! +!if(idry.eq.1)goto 80 + do 50 i = its,ite + qx(i)=qv1d(i) + tvcon=(1.+ep1*qx(i)) + thvx(i)=thx(i)*tvcon + scr4(i)=scr3(i)*tvcon + 50 continue +! + do 60 i=its,ite + e1=svp1*exp(svp2*(tgdsa(i)-svpt0)/(tgdsa(i)-svp3)) + !the saturation vapor pressure for salty water is on average 2% lower + if(xland(i).gt.1.5 .and. lakemask(i).eq.0.) e1=e1*salinity_factor + !for land points qsfc can come from previous time step + if(xland(i).gt.1.5.or.qsfc(i).le.0.0)qsfc(i)=ep2*e1/(psfc(i)-e1) +!QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE +!Q2SAT = QGH IN LSM + e1=svp1*exp(svp2*(t1d(i)-svpt0)/(t1d(i)-svp3)) + pl=p1d(i)/1000. + qgh(i)=ep2*e1/(pl-e1) + cpm(i)=cp*(1.+0.8*qx(i)) + 60 continue + 80 continue + +!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND +! LEVEL, AND THE LAYER THICKNESSES. + + do 90 i = its,ite + zqklp1(i)=0. + rhox(i)=psfc(i)*1000./(r*scr4(i)) + 90 continue +! + do 110 i = its,ite + zqkl(i)=dz8w1d(i)+zqklp1(i) + 110 continue +! + do 120 i = its,ite + za(i)=0.5*(zqkl(i)+zqklp1(i)) + 120 continue +! + do 160 i=its,ite + govrth(i)=g/thx(i) + 160 continue + +!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO +! AKB(1976), EQ(12). + do 260 i = its,ite + gz1oz0(i)=alog((za(i)+znt(i))/znt(i)) ! log((z+z0)/z0) + gz2oz0(i)=alog((2.+znt(i))/znt(i)) ! log((2+z0)/z0) + gz10oz0(i)=alog((10.+znt(i))/znt(i)) ! log((10+z0)z0) + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif + wspd(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) + + tskv=thgb(i)*(1.+ep1*qsfc(i)) + dthvdz=(thvx(i)-tskv) +!-----CONVECTIVE VELOCITY SCALE VC AND SUBGRID-SCALE VELOCITY VSG +! FOLLOWING BELJAARS (1994, QJRMS) AND MAHRT AND SUN (1995, MWR) +! ... HONG AUG. 2001 +! +! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) +! USE BELJAARS OVER LAND, OLD MM5 (WYNGAARD) FORMULA OVER WATER + if(xland(i).lt.1.5) then + fluxc = max(hfx(i)/rhox(i)/cp & + + ep1*tskv*qfx(i)/rhox(i),0.) + vconv = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 + else + if(-dthvdz.ge.0)then + dthvm=-dthvdz + else + dthvm=0. + endif +! vconv = 2.*sqrt(dthvm) +! V3.7: REDUCING CONTRIBUTION IN CALM CONDITIONS + vconv = sqrt(dthvm) + endif +! MAHRT AND SUN LOW-RES CORRECTION + 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)) +!-----IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 + if(mol(i).lt.0.)br(i)=amin1(br(i),0.0) + rmol(i)=-govrth(i)*dthvdz*za(i)*karman + 260 continue + +! +!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: +! +! +! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) +! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). +! +! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: +! +! 1. BR .GE. 0.0; +! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), +! +! 3. BR .EQ. 0.0 +! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), +! +! 4. BR .LT. 0.0 +! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). +! + + do 320 i = its,ite +! + if(br(i).gt.0) then + if(br(i).gt.250.0) then + zol(i)=zolri(250.0,za(i),znt(i)) + else + zol(i)=zolri(br(i),za(i),znt(i)) + endif + endif +! + if(br(i).lt.0) then + if(ust(i).lt.0.001)then + zol(i)=br(i)*gz1oz0(i) + else + if(br(i).lt.-250.0) then + zol(i)=zolri(-250.0,za(i),znt(i)) + else + zol(i)=zolri(br(i),za(i),znt(i)) + endif + endif + endif +! +! ... paj: compute integrated similarity functions. +! + zolzz=zol(i)*(za(i)+znt(i))/za(i) ! (z+z0/L + zol10=zol(i)*(10.+znt(i))/za(i) ! (10+z0)/L + zol2=zol(i)*(2.+znt(i))/za(i) ! (2+z0)/L + zol0=zol(i)*znt(i)/za(i) ! z0/L + zl2=(2.)/za(i)*zol(i) ! 2/L + zl10=(10.)/za(i)*zol(i) ! 10/L + + if((xland(i)-1.5).lt.0.)then + zl=(0.01)/za(i)*zol(i) ! (0.01)/L + else + zl=zol0 ! z0/L + endif + + if(br(i).lt.0.)goto 310 ! go to unstable regime (class 4) + if(br(i).eq.0.)goto 280 ! go to neutral regime (class 3) +! +!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: +! + regime(i)=1. +! +! ... paj: psim and psih. follows cheng and brutsaert 2005 (cb05). +! + psim(i)=psim_stable(zolzz)-psim_stable(zol0) + psih(i)=psih_stable(zolzz)-psih_stable(zol0) +! + psim10(i)=psim_stable(zol10)-psim_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) +! + psim2(i)=psim_stable(zol2)-psim_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) +! +! ... paj: preparations to compute psiq. follows cb05+carlson boland jam 1978. +! + pq(i)=psih_stable(zol(i))-psih_stable(zl) + pq2(i)=psih_stable(zl2)-psih_stable(zl) + pq10(i)=psih_stable(zl10)-psih_stable(zl) +! +! 1.0 over monin-obukhov length + rmol(i)=zol(i)/za(i) +! + goto 320 +! +!-----CLASS 3; FORCED CONVECTION: +! + 280 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) +! +! paj: preparations to compute PSIQ. +! + pq(i)=psih(i) + pq2(i)=psih2(i) + pq10(i)=0. +! + zol(i)=0. + rmol(i) = zol(i)/za(i) + + goto 320 +! +!-----CLASS 4; FREE CONVECTION: +! + 310 continue + regime(i)=4. +! +! ... paj: PSIM and PSIH ... +! + psim(i)=psim_unstable(zolzz)-psim_unstable(zol0) + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) +! + psim10(i)=psim_unstable(zol10)-psim_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) +! + psim2(i)=psim_unstable(zol2)-psim_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) +! +! ... paj: preparations to compute PSIQ +! + pq(i)=psih_unstable(zol(i))-psih_unstable(zl) + pq2(i)=psih_unstable(zl2)-psih_unstable(zl) + pq10(i)=psih_unstable(zl10)-psih_unstable(zl) +! +!-----LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS +!-----THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL + psih(i)=amin1(psih(i),0.9*gz1oz0(i)) + psim(i)=amin1(psim(i),0.9*gz1oz0(i)) + psih2(i)=amin1(psih2(i),0.9*gz2oz0(i)) + psim10(i)=amin1(psim10(i),0.9*gz10oz0(i)) +! +! AHW: mods to compute ck, cd + psih10(i)=amin1(psih10(i),0.9*gz10oz0(i)) + rmol(i) = zol(i)/za(i) + + 320 continue +! +!-----COMPUTE THE FRICTIONAL VELOCITY: +! ZA(1982) EQS(2.60),(2.61). +! + do 330 i = its,ite + dtg=thx(i)-thgb(i) + psix=gz1oz0(i)-psim(i) + psix10=gz10oz0(i)-psim10(i) + +! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL +! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 +! PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) + psit=gz1oz0(i)-psih(i) + psit2=gz2oz0(i)-psih2(i) +! + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif +! + psiq=alog(karman*ust(i)*za(i)/xka+za(i)/zl)-pq(i) + psiq2=alog(karman*ust(i)*2./xka+2./zl)-pq2(i) + +! AHW: mods to compute ck, cd + psiq10=alog(karman*ust(i)*10./xka+10./zl)-pq10(i) + +! v3.7: using fairall 2003 to compute z0q and z0t over water: +! adapted from module_sf_mynn.f + if((xland(i)-1.5).ge.0.) then + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 + restar=ust(i)*znt(i)/visc + z0t = (5.5e-5)*(restar**(-0.60)) + z0t = min(z0t,1.0e-4) + z0t = max(z0t,2.0e-9) + z0q = z0t + +! following paj: + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif + psit=alog((za(i)+z0t)/z0t)-psih(i) + psit2=alog((2.+z0t)/z0t)-psih2(i) + + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) + endif + + if(present(isftcflx)) then + if(isftcflx.eq.1 .and. (xland(i)-1.5).ge.0.) then +! v3.1 +! z0q = 1.e-4 + 1.e-3*(max(0.,ust(i)-1.))**2 +! hfip1 +! z0q = 0.62*2.0e-5/ust(i) + 1.e-3*(max(0.,ust(i)-1.5))**2 +! v3.2 + z0q = 1.e-4 +! +! ... paj: recompute psih for z0q +! + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psit=psiq + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) + psit2=psiq2 + endif + if(isftcflx.eq.2 .and. (xland(i)-1.5).ge.0.) then +! AHW: Garratt formula: Calculate roughness Reynolds number +! Kinematic viscosity of air (linear approc to +! temp dependence at sea level) +! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which +! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60 + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 +! visc=1.5e-5 + restar=ust(i)*znt(i)/visc + gz0ozt=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.71)-5.) +! +! ... paj: compute psih for z0t for temperature ... +! + z0t=znt(i)/exp(gz0ozt) +! + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! +! psit=gz1oz0(i)-psih(i)+restar2 +! psit2=gz2oz0(i)-psih2(i)+restar2 + psit=alog((za(i)+z0t)/z0t)-psih(i) + psit2=alog((2.+z0t)/z0t)-psih2(i) +! + gz0ozq=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.60)-5.) + z0q=znt(i)/exp(gz0ozq) +! + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) +! psiq=gz1oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. +! psiq2=gz2oz0(i)-psih2(i)+2.28*sqrt(sqrt(restar))-2. +! psiq10=gz10oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. + endif + endif + if(present(ck) .and. present(cd) .and. present(cka) .and. present(cda)) then + ck(i)=(karman/psix10)*(karman/psiq10) + cd(i)=(karman/psix10)*(karman/psix10) + cka(i)=(karman/psix)*(karman/psiq) + cda(i)=(karman/psix)*(karman/psix) + endif + if(present(iz0tlnd)) 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 if iz0tlnd = 1 +! If iz0tlnd = 2, use traditional value + + if(iz0tlnd.eq.1) then + czil = 10.0 ** ( -0.40 * ( zl / 0.07 ) ) + elseif(iz0tlnd.eq.2) then + czil = 0.1 + endif +! +! ... paj: compute phish for z0t over land +! + z0t=znt(i)/exp(czil*karman*sqrt(restar)) +! + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0t)/z0t)-psih(i) + psiq2=alog((2.+z0t)/z0t)-psih2(i) + psit=psiq + psit2=psiq2 +! +! psit=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) +! psiq=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) +! psit2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) +! psiq2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) + endif + endif +! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE + ust(i)=0.5*ust(i)+0.5*karman*wspd(i)/psix +! TKE coupling: compute ust without vconv for use in tke scheme + wspdi(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) + if(present(ustm)) then + ustm(i)=0.5*ustm(i)+0.5*karman*wspdi(i)/psix + endif + + u10(i)=ux(i)*psix10/psix + v10(i)=vx(i)*psix10/psix + th2(i)=thgb(i)+dtg*psit2/psit + q2(i)=qsfc(i)+(qx(i)-qsfc(i))*psiq2/psiq + t2(i) = th2(i)*(psfcpa(i)/p1000mb)**rovcp +! + if((xland(i)-1.5).lt.0.)then + ust(i)=amax1(ust(i),0.001) + endif + mol(i)=karman*dtg/psit/prt + denomq(i)=psiq + denomq2(i)=psiq2 + denomt2(i)=psit2 + fm(i)=psix + fh(i)=psit + 330 continue +! + 335 continue + +!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: + if(present(scm_force_flux) ) then + if(scm_force_flux) goto 350 + endif + do i = its,ite + qfx(i)=0. + hfx(i)=0. + enddo + 350 continue + + if(.not. isfflx) goto 410 + +!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). + do 360 i = its,ite + if((xland(i)-1.5).ge.0)then +! znt(i)=czo*ust(i)*ust(i)/g+ozo + ! PSH - formulation for depth-dependent roughness from + ! ... Jimenez and Dudhia, 2018 + if(shalwater_z0) then + znt(i) = depth_dependent_z0(water_depth(i),znt(i),ust(i)) + else + !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) + endif +! COARE 3.5 (Edson et al. 2013) +! czc = 0.0017*wspd(i)-0.005 +! czc = min(czc,0.028) +! znt(i)=czc*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) +! AHW: change roughness length, and hence the drag coefficients Ck and Cd + if(present(isftcflx)) then + if(isftcflx.ne.0) then +! znt(i)=10.*exp(-9.*ust(i)**(-.3333)) +! znt(i)=10.*exp(-9.5*ust(i)**(-.3333)) +! znt(i)=znt(i) + 0.11*1.5e-5/amax1(ust(i),0.01) +! znt(i)=0.011*ust(i)*ust(i)/g+ozo +! znt(i)=max(znt(i),3.50e-5) +! AHW 2012: + zw = min((ust(i)/1.06)**(0.3),1.0) + zn1 = 0.011*ust(i)*ust(i)/g + ozo + zn2 = 10.*exp(-9.5*ust(i)**(-.3333)) + & + 0.11*1.5e-5/amax1(ust(i),0.01) + znt(i)=(1.0-zw) * zn1 + zw * zn2 + znt(i)=min(znt(i),2.85e-3) + znt(i)=max(znt(i),1.27e-7) + endif + endif + zl = znt(i) + else + zl = 0.01 + endif + flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/denomq(i) +! flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/( & +! alog(karman*ust(i)*za(i)/xka+za(i)/zl)-psih(i)) + dtthx=abs(thx(i)-thgb(i)) + if(dtthx.gt.1.e-5)then + flhc(i)=cpm(i)*rhox(i)*ust(i)*mol(i)/(thx(i)-thgb(i)) +! write(*,1001)flhc(i),cpm(i),rhox(i),ust(i),mol(i),thx(i),thgb(i),i + 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) + else + flhc(i)=0. + endif + 360 continue + +! +!-----COMPUTE SURFACE MOIST FLUX: +! +!IF(IDRY.EQ.1)GOTO 390 +! + if(present(scm_force_flux)) then + if(scm_force_flux) goto 405 + endif + + do 370 i = its,ite + qfx(i)=flqc(i)*(qsfc(i)-qx(i)) +! qfx(i)=amax1(qfx(i),0.) + lh(i)=xlv*qfx(i) + 370 continue + +!-----COMPUTE SURFACE HEAT FLUX: +! + 390 continue + do 400 i = its,ite + if(xland(i)-1.5.gt.0.)then + hfx(i)=flhc(i)*(thgb(i)-thx(i)) +! if(present(isftcflx)) then +! if(isftcflx.ne.0) then +! AHW: add dissipative heating term (commented out in 3.6.1) +! hfx(i)=hfx(i)+rhox(i)*ustm(i)*ustm(i)*wspdi(i) +! endif +! endif + elseif(xland(i)-1.5.lt.0.)then + hfx(i)=flhc(i)*(thgb(i)-thx(i)) +! hfx(i)=amax1(hfx(i),-250.) + endif + 400 continue + + 405 continue + + do i = its,ite + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif +!v3.1.1 +! chs(i)=ust(i)*karman/(alog(karman*ust(i)*za(i) & +! /xka+za(i)/zl)-psih(i)) + chs(i)=ust(i)*karman/denomq(i) +! gz2oz0(i)=alog(2./znt(i)) +! psim2(i)=-10.*gz2oz0(i) +! psim2(i)=amax1(psim2(i),-10.) +! psih2(i)=psim2(i) +! v3.1.1 +! cqs2(i)=ust(i)*karman/(alog(karman*ust(i)*2.0 & +! /xka+2.0/zl)-psih2(i)) +! chs2(i)=ust(i)*karman/(gz2oz0(i)-psih2(i)) + cqs2(i)=ust(i)*karman/denomq2(i) + chs2(i)=ust(i)*karman/denomt2(i) + enddo + + 410 continue + +!jdf +! do i = its,ite +! if(ust(i).ge.0.1) then +! rmol(i)=rmol(i)*(-flhc(i))/(ust(i)*ust(i)*ust(i)) +! else +! rmol(i)=rmol(i)*(-flhc(i))/(0.1*0.1*0.1) +! endif +! enddo +!jdf + + errmsg = 'sf_sfclayrev_run OK' + errflg = 0 + + end subroutine sf_sfclayrev_run + +!================================================================================================================= + real(kind=kind_phys) function zolri(ri,z,z0) + real(kind=kind_phys),intent(in):: ri,z,z0 + + integer:: iter + real(kind=kind_phys):: fx1,fx2,x1,x2 + + + if(ri.lt.0.)then + x1=-5. + x2=0. + else + x1=0. + x2=5. + endif + + fx1=zolri2(x1,ri,z,z0) + fx2=zolri2(x2,ri,z,z0) + iter = 0 + do while (abs(x1 - x2) > 0.01) + if (iter .eq. 10) return +!check added for potential divide by zero (2019/11) + if(fx1.eq.fx2)return + if(abs(fx2).lt.abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,z,z0) + zolri=x1 + else + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,z,z0) + zolri=x2 + endif + iter = iter + 1 + enddo + + return + end function zolri + +!================================================================================================================= + real(kind=kind_phys) function zolri2(zol2,ri2,z,z0) + real(kind=kind_phys),intent(in):: ri2,z,z0 + real(kind=kind_phys),intent(inout):: zol2 + real(kind=kind_phys):: psih2,psix2,zol20,zol3 + + if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 + + zol20=zol2*z0/z ! z0/L + zol3=zol2+zol20 ! (z+z0)/L + + if(ri2.lt.0) then + psix2=log((z+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + psih2=log((z+z0)/z0)-(psih_unstable(zol3)-psih_unstable(zol20)) + else + psix2=log((z+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + psih2=log((z+z0)/z0)-(psih_stable(zol3)-psih_stable(zol20)) + endif + + zolri2=zol2*psih2/psix2**2-ri2 + + return + end function zolri2 + +!================================================================================================================= +! +! ... integrated similarity functions ... +! + real(kind=kind_phys) function psim_stable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + + return + end function psim_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_stable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + + return + end function psih_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: psimc,psimk,x,y,ym + x=(1.-16.*zolf)**.25 + psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) + + ym=(1.-10.*zolf)**0.33 + psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) + + return + end function psim_unstable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: psihc,psihk,y,yh + y=(1.-16.*zolf)**.5 + psihk=2.*log((1+y)/2.) + + yh=(1.-34.*zolf)**0.33 + psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) + + return + end function psih_unstable_full + +!================================================================================================================= +! ... look-up table functions ... + real(kind=kind_phys) function psim_stable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + psim_stable = psim_stable_full(zolf) + endif + + return + end function psim_stable + +!================================================================================================================= + real(kind=kind_phys) function psih_stable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + psih_stable = psih_stable_full(zolf) + endif + + return + end function psih_stable + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + psim_unstable = psim_unstable_full(zolf) + endif + + return + end function psim_unstable + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + psih_unstable = psih_unstable_full(zolf) + endif + + return + end function psih_unstable + +!================================================================================================================= + real(kind=kind_phys) function depth_dependent_z0(water_depth,z0,ust) + real(kind=kind_phys),intent(in):: water_depth,z0,ust + real(kind=kind_phys):: depth_b + real(kind=kind_phys):: effective_depth + if(water_depth .lt. 10.0) then + effective_depth = 10.0 + elseif(water_depth .gt. 100.0) then + effective_depth = 100.0 + else + effective_depth = water_depth + endif + + depth_b = 1 / 30.0 * log (1260.0 / effective_depth) + depth_dependent_z0 = exp((2.7 * ust - 1.8 / depth_b) / (ust + 0.17 / depth_b) ) + depth_dependent_z0 = MIN(depth_dependent_z0,0.1) + + return + end function depth_dependent_z0 + +!================================================================================================================= + end module sf_sfclayrev +!================================================================================================================= diff --git a/run/README.namelist b/run/README.namelist index 4efccbe253..be2a30b145 100644 --- a/run/README.namelist +++ b/run/README.namelist @@ -251,7 +251,8 @@ Namelist variables specifically for the WPS input for real: rh2qv_method = 1, ! which method to use to computer mixing ratio from RH: default is option 1, the old MM5 method; option 2 uses a WMO recommended method (WMO-No. 49, corrigendum, August 2000) - - there is a difference between the two methods though small + use_sh_qv = .false., ! whether to use specific humidity or mixing ratio data from input + recommended if input data has high vertical resolution interp_theta = .false. ! If set to .false., it will vertically interpolate temperature instead of potential temperature, which may reduce bias when compared with input data @@ -487,26 +488,15 @@ Namelist variables for controlling the adaptive time step option: = 13, SBU_YLIN scheme = 14, WDM 5-class scheme = 16, WDM 6-class scheme - = 17, NSSL 2-moment 4-ice scheme (steady background CCN) - = 18, NSSL 2-moment 4-ice scheme with predicted CCN (better for idealized than real cases) - to set a global CCN value, use - nssl_cccn = 0.7e9 ; CCN for NSSL scheme (18). - Also sets same value to ccn_conc for mp_physics=18 - = 19, NSSL 1-moment (7 class: qv,qc,qr,qi,qs,qg,qh; predicts graupel density) - = 21, NSSL 1-moment, (6-class), very similar to Gilmore et al. 2004 - Can set intercepts and particle densities in physics namelist, e.g., nssl_cnor + = 18, NSSL 2-moment 4-ice scheme with predicted (unactivated) CCN (or activated CCN) + to change global CCN value, use + nssl_cccn = 0.7e9 ; CCN (#/m^3 at sea level pressure) for NSSL scheme (18) or nssl_ccn_on=1 + Also sets ccn_conc for mp_physics=18 For NSSL 1-moment schemes, intercept and particle densities can be set for snow, graupel, hail, and rain. For the 1- and 2-moment schemes, the shape parameters for graupel and hail can be set. - nssl_alphah = 0. ! shape parameter for graupel - nssl_alphahl = 2. ! shape parameter for hail - nssl_cnoh = 4.e5 ! graupel intercept - nssl_cnohl = 4.e4 ! hail intercept - nssl_cnor = 8.e5 ! rain intercept - nssl_cnos = 3.e6 ! snow intercept - nssl_rho_qh = 500. ! graupel density - nssl_rho_qhl = 900. ! hail density - nssl_rho_qs = 100. ! snow density + PLEASE SEE README.NSSLmp for options affecting the NSSL scheme + = 17, 19, 21, 22: Legacy NSSL-MP options: see README.NSSLmp for equivalent settings with 18 = 24, WSM 7-class scheme (separate hail and graupel categories) = 26, WDM 7-class scheme (separate hail and graupel categories) = 28, aerosol-aware Thompson scheme with water- and ice-friendly aerosol climatology @@ -549,11 +539,13 @@ Namelist variables for controlling the adaptive time step option: mp_zero_out = 0, ! no action taken, no adjustment to any moist field = 1, ! except for Qv, all other moist arrays are set to zero - if they fall below a critical value + if they fall below a critical value ('moist' array only) = 2, ! Qv is .GE. 0, all other moist arrays are set to zero - if they fall below a critical value + if they fall below a critical value ('moist' array only) mp_zero_out_thresh = 1.e-8 ! critical value for moist array threshold, below which moist arrays (except for Qv) are set to zero (kg/kg) + mp_zero_out_all = 0, ! if =1 and mp_zero_out>0, then reproduce old behavior and + apply threshold to scalar, chem, and tracer arrays gsfcgce_hail = 0 ! for running gsfcgce microphysics with graupel = 1 ! for running gsfcgce microphysics with hail @@ -571,14 +563,14 @@ Namelist variables for controlling the adaptive time step option: acc_phy_tend = 0 ! set to =1 to output 16 accumulated physics tendencies for potential temp, water vaopr mixing ratio, and U/V wind components; default is 0=off (new in 4.4) progn (max_dom) = 0 ! switch to use mix-activate scheme (Only for Morrison, WDM6, WDM5, - and NSSL_2MOMCCN/NSSL_2MOM - ccn_conc = 1.E8 ! CCN concentration, used by WDM schemes + and NSSL_2MOM) + ccn_conc = 1.E8 ! CCN concentration, used by WDM schemes (set automatically for NSSL_2MOM using nssl_cccn) no_mp_heating = 0 ! normal = 1 ! turn off latent heating from a microphysics scheme use_mp_re = 1 ! whether to use effective radii computed in mp schemes in RRTMG 0: do not use; 1: use effective radii - (The mp schemes that compute effective radii are 3,4,6,7,8,10,14,16,17-21,24,26,28,50-53,55) + (The mp schemes that compute effective radii are 3,4,6,7,8,10,14,16,18,24,26,28,50-53,55) force_read_thompson = .false. ! whether to read tables for mp_physics = 8,28 write_thompson_tables = .true. ! whether to read or compute tables for mp_phyiscs = 8,28 @@ -969,6 +961,13 @@ Namelist variables for controlling the adaptive time step option: * Note: If the number of urban category in the input files is inconsistent with the namelist option, error messages will occur. The method to create the LCZ data is described here: http://www.wudapt.org/ + slucm_distributed_drag = .false. ! option to use spatially varying 2-D urban Zero-plane Displacement, Roughness length for momentum, Frontal area index + ! currently does not work with LCZ, only works with single-layer urban physics (urban_physics=1) + ! need additional aforementioned 3 input variables in wrfinput file + distributed_ahe_opt = 0, ! option to handle anthropogenic surface heat flux (need additional input in wrfinput file) + = 0: no anthropogenic surface heat flux from input data + = 1: add to first level temperature tendency + = 2: add to surface sensible heat flux num_soil_cat = 16, ! number of soil categories in input data pxlsm_smois_init(max_dom) = 1 ! PXLSM Soil moisture initialization option @@ -1063,8 +1062,10 @@ Namelist variables for controlling the adaptive time step option: ua_phys = .false. ! Option to activate UA Noah changes: a different snow-cover physics in Noah, aimed particularly toward improving treatment of snow as it relates to the vegetation canopy. Also uses new columns added in VEGPARM.TBL - do_radar_ref = 0, ! 1 = allows radar reflectivity to be computed using mp-scheme-specific - parameters. Currently works for mp_physics = 2,4,6,7,8,10,14,16,24,26,28 + do_radar_ref = 0, ! 1 = allows radar reflectivity to be computed using mp-scheme-specific + parameters. Currently works for mp_physics = 2,4,6,7,8,10,14,16,24,26,28 + Note that reflectivity is always computed for mp_physics = 9,18, and is + also set =1 when nwp_diagnostics=1 hailcast_opt (max_dom) = 0, ! 1 = 1-D hail growth model which predicts 1st-5th rank-ordered hail diameters, mean hail diameter and standard deviation of hail diameter. (Adams-Selin and Ziegler, MWR Dec 2016.) haildt (max_dom) = 0., ! seconds between WRF-HAILCAST calls (s) @@ -1126,10 +1127,26 @@ Options for MAD-WRF - see doc/README.madwrf for usage information Options for wind turbine drag parameterization: - windfarm_opt (max_dom) = 0 ! 1 = Simulates the effects of wind turbines in the atmospheric evolution + windfarm_opt (max_dom) = 0 ! 1 = Simulates the effects of wind turbines in the atmospheric evolution, A\activates the wind farm parameterization by Fitch et al (2012) + ! 2 = Activate the new wind farm scheme (mav scheme) based on Ma et al. (2022). + This is similar to option 1, but it also considers subgrid-scale wind turbine wake effects windfarm_ij = 0 ! whether to use lat-lon or i-j coordinate as wind turbine locations ! 0 = The coordinate of the turbines are defined in terms of lat-lon ! 1 = The coordinate of the turbines are defined in terms of grid points + ! 2 = Valid only with windfarm_opt=2. The coordinate of the turbines are defined + in terms of lat-lon with the filename of 'windturbines-ll.txt' + windfarm_wake_model = 2 ! Subgrid-scale wind turbine wake model, valid only with windfarm_opt=2, default is 2 + ! 1 = The Jensen model + ! 2 = The XA model + ! 3 = The GM model (windfarm_method is not used) + ! 4 = Jensen and XA ensemble + ! 5 = Jensen, XA and GM ensemble + windfarm_overlap_method = 4 ! Wake superposition method for the Jensen and XA wind turbine wake model, valid only with windfarm_opt=2, default is 4 + ! 1 = linear superposition + ! 2 = squared superposition + ! 3 = modified squared superposition + ! 4 = superposition of the hub-height wind speed (Ma et al. 2022) + windfarm_deg = 0. ! The rotation degree of the wind farm layout. This is valid only when 'windfarm_opt=2' and 'windfarm_ij=1' windfarm_tke_factor = 0.25 ! Correction factor applied to the TKE coefficient (deafault is 0.25, Archer et al. 2020) diff --git a/run/URBPARM_LCZ.TBL b/run/URBPARM_LCZ.TBL index 80e6809c17..450d765f9d 100644 --- a/run/URBPARM_LCZ.TBL +++ b/run/URBPARM_LCZ.TBL @@ -32,21 +32,21 @@ SIGMA_ZED: 4.0, 3.0, 1.0, 1., 1., 1., 1., 1., 1., 1., 1. # ROOF_WIDTH: Roof (i.e., building) width [ m ] # (sf_urban_physics=1) -ROOF_WIDTH: 31.7, 25.7, 17.6, 17.6, 17.6, 17.6, 17.6, 17.6, 17.6, 17.6, 10. +ROOF_WIDTH: 22.2, 22., 9.6, 42.86, 26.25, 13., 25., 28.9, 43.33, 23.8, 5. # # ROAD_WIDTH: road width [ m ] # (sf_urban_physics=1) # -ROAD_WIDTH: 98.9, 39.2, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0, 108.0 +ROAD_WIDTH: 20., 14., 5.2, 50.0, 35.0, 13.0, 3.33, 32.5, 43.3, 28.6, 100.0 # # AH: Anthropogenic heat [ W m{-2} ] # (sf_urban_physics=1) # -AH: 100.0, 35.0, 30.0, 30.0, 15.0, 10.0, 30.0, 40.0, 5.0, 300.0, 0 +AH: 175.0, 37.5, 37.5, 25.0, 12.5, 12.5, 17.5, 25.0, 5.0, 350.0, 350.0 # @@ -54,7 +54,7 @@ AH: 100.0, 35.0, 30.0, 30.0, 15.0, 10.0, 30.0, 40.0, 5.0, 300.0, 0 # (sf_urban_physics=1) # -ALH: 20.0, 25.0, 40.0, 20.0, 25.0, 40.0, 20.0, 25.0, 40.0, 20.0, 0 +ALH: 20.0, 25.0, 40.0,20.0, 25.0, 40.0,20.0, 25.0, 40.0,20.0, 25.0 # # AKANDA_URBAN: Coefficient modifying the Kanda approach to computing @@ -232,90 +232,92 @@ DZGR: 0.05 0.10 0.15 0.20 # (sf_urban_physics=1,2,3) # -FRC_URB: 1.00, 0.99, 1.00, 0.65, 0.7, 0.65, 0.3, 0.85, 0.3, 0.55, 1.00 +FRC_URB: 0.95, 0.9,0.85, 0.65, 0.7, 0.6, 0.85, 0.85, 0.3, 0.55, 1.00 + # # CAPR: Heat capacity of roof [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPR: 1.8E6, 1.8E6, 1.44E6, 1.8E6, 1.8E6, 1.44E6, 2.0E6, 1.8E6, 1.44E6, 2.0E6, 1.8E6 +CAPR: 1.32E6,1.32E6,1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6, 1.32E6 # # CAPB: Heat capacity of building wall [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPB: 1.8E6, 2.67E6, 2.05E6, 2.0E6, 2.0E6, 2.05E6, 0.72E6, 1.8E6, 2.56E6, 1.69E6, 1.8E6 +CAPB: 1.54E6,1.54E6,1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6, 1.54E6 # # CAPG: Heat capacity of ground (road) [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPG: 1.75E6, 1.68E6, 1.63E6, 1.54E6, 1.50E6, 1.47E6, 1.67E6, 1.38E6, 1.37E6, 1.49E6, 1.38E6 +CAPG: 1.74E6,1.74E6,1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6, 1.74E6 # # AKSR: Thermal conductivity of roof [ J m{-1} s{-1} K{-1} ] # (sf_urban_physics=1,2,3) # -AKSR: 1.25, 1.25, 1.00, 1.25, 1.25, 1.00, 2.0, 1.25, 1.00, 2.00, 1.25 +AKSR: 1.54,1.54,1.54, 1.54, 1.54, 1.54, 1.54, 1.54, 1.54, 1.54, 1.54 # # AKSB: Thermal conductivity of building wall [ J m{-1} s{-1} K{-1} ] # (sf_urban_physics=1,2,3) # -AKSB: 1.09, 1.5, 1.25, 1.45, 1.45, 1.25, 0.5, 1.25, 1.00, 1.33, 1.25 +AKSB: 1.51,1.51,1.51, 1.51, 1.51, 1.51,1.51,1.51,1.51, 1.51, 1.51 # # AKSG: Thermal conductivity of ground (road) [ J m{-1} s{-1} K{-1} ] # (sf_urban_physics=1,2,3) # -AKSG: 0.77, 0.73, 0.69, 0.64, 0.62, 0.60, 0.72, 0.51, 0.55, 0.61, 0.51 +AKSG: 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82, 0.82 # # ALBR: Surface albedo of roof [ fraction ] # (sf_urban_physics=1,2,3) # -ALBR: 0.13, 0.18, 0.15, 0.13, 0.13, 0.13, 0.15, 0.18, 0.13, 0.10, 0.13 +ALBR: 0.30, 0.30 0.30, 0.30, 0.30, 0.30, 0.30, 0.30, 0.30, 0.30, 0.30 + # # ALBB: Surface albedo of building wall [ fraction ] # (sf_urban_physics=1,2,3) # -ALBB: 0.25, 0.20, 0.20, 0.25, 0.25, 0.25, 0.20, 0.25, 0.25, 0.20, 0.20 +ALBB: 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 # # ALBG: Surface albedo of ground (road) [ fraction ] # (sf_urban_physics=1,2,3) # -ALBG: 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.18, 0.14, 0.14, 0.14, 0.14 +ALBG: 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08 # # EPSR: Surface emissivity of roof [ - ] # (sf_urban_physics=1,2,3) # -EPSR: 0.91, 0.91, 0.91, 0.91, 0.91, 0.91, 0.28, 0.91, 0.91, 0.91, 0.95 +EPSR: 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90 # # EPSB: Surface emissivity of building wall [-] # (sf_urban_physics=1,2,3) # -EPSB: 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.95 +EPSB: 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90 # # EPSG: Surface emissivity of ground (road) [ - ] # (sf_urban_physics=1,2,3) # -EPSG: 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.92, 0.95, 0.95, 0.95, 0.95 +EPSG: 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95 # # Z0B: Roughness length for momentum, over building wall [ m ] @@ -348,14 +350,14 @@ Z0R: 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 # (sf_urban_physics=1,2,3) # -TRLEND: 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00 +TRLEND: 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00 # # TBLEND: Lower boundary temperature for building wall temperature [ K ] # (sf_urban_physics=1,2,3) # -TBLEND: 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00, 299.00 +TBLEND: 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00 # # TGLEND: Lower boundary temperature for ground (road) temperature [ K ] @@ -368,7 +370,7 @@ TGLEND: 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, 293.00, # (sf_urban_physics=3) # -COP: 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5, 3.5 +COP: 4., 4., 4., 4., 4., 4., 4., 4., 4., 4., 4. # # BLDAC_FRC: fraction of buildings installed with A/C systems [ - ] # (sf_urban_physics=3) @@ -388,7 +390,7 @@ COOLED_FRC: 1.0, 1.0, 1.0,1.0, 1.0, 1.0,1.0, 1.0, 1.0,1.0, 1.0 # (sf_urban_physics=3) # -PWIN: 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.9, 0.2, 0.2, 0.2, 0.0 +PWIN: 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.0 # # BETA: Thermal efficiency of heat exchanger @@ -450,7 +452,7 @@ GAPHUM: 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0. # (sf_urban_physics=3) # -PERFLO: 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.00 +PERFLO: 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.00 # @@ -465,7 +467,7 @@ HSEQUIP: 0.25 0.25 0.25 0.25 0.25 0.25 0.25 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 # (sf_urban_physics=3) # -HSEQUIP_SCALE_FACTOR: 36.00, 20.00, 20.00, 36.00, 20.00, 20.00, 20.00, 36.00, 20.00, 20.00, 20.00 +HSEQUIP_SCALE_FACTOR: 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00, 20.00 # @@ -480,7 +482,7 @@ GR_FLAG:0 # (sf_urban_physics=3) # -GR_TYPE: 2 +GR_TYPE: 1 # # GR_FRAC_ROOF: fraction of green roof over the roof (0:1) @@ -502,8 +504,9 @@ IRHO:0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1 # (sf_urban_physics=3) # -PV_FRAC_ROOF: 0,0,0,0,0,0,0,0,0,0,0 +PV_FRAC_ROOF: 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0. +# STREET PARAMETERS: @@ -513,26 +516,26 @@ STREET PARAMETERS: # category direction width width # [index] [deg from N] [m] [m] - 1 0.0 15. 12. - 1 90.0 15. 12. - 2 0.0 10. 20. - 2 90.0 10. 20. - 3 0.0 5.7 9. - 3 90.0 5.7 9. - 4 0.0 30.0 20. - 4 90.0 30.0 20. - 5 0.0 20.0 20. - 5 90.0 20.0 20. - 6 0.0 12.4 10.5 - 6 90.0 12.4 10.5 - 7 0.0 10. 20. - 7 90.0 10. 20. - 8 0.0 32.5 28.8 - 8 90.0 32.5 28.8 - 9 0.0 10. 10. - 9 90.0 10. 10. - 10 0.0 28.5 23.8 - 10 90.0 28.5 23.8 + 1 0.0 20. 22.22 + 1 90.0 20. 22.22 + 2 0.0 14. 22. + 2 90.0 14. 22. + 3 0.0 5.2 9.6 + 3 90.0 5.2 9.6 + 4 0.0 50.0 42.86 + 4 90.0 50.0 42.86 + 5 0.0 35.0 26.25 + 5 90.0 35.0 26.25 + 6 0.0 13.0 13. + 6 90.0 13.0 13. + 7 0.0 3.33 25. + 7 90.0 3.33 25. + 8 0.0 32.5 28.9 + 8 90.0 32.5 28.9 + 9 0.0 43.3 43.33 + 9 90.0 43.3 43.33 + 10 0.0 28.6 23.8 + 10 90.0 28.6 23.8 11 0.0 100. 5. 11 90.0 100. 5. @@ -639,7 +642,6 @@ BUILDING HEIGHTS: 11 # height Percentage # [m] [%] - 5.0 100.0 + 5.0 100.0 END BUILDING HEIGHTS - diff --git a/share/CMakeLists.txt b/share/CMakeLists.txt new file mode 100644 index 0000000000..229efae1e5 --- /dev/null +++ b/share/CMakeLists.txt @@ -0,0 +1,77 @@ +# WRF CMake Build + +target_include_directories( + ${PROJECT_NAME}_Core + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +######################################################################################################################## +# +# Now define base share +# +######################################################################################################################## +target_sources( + ${PROJECT_NAME}_Core + PRIVATE + + module_model_constants.F + module_llxy.F + module_soil_pre.F + module_date_time.F + module_bc.F + + module_bc_time_utilities.F + module_get_file_names.F + module_compute_geop.F + module_chem_share.F + module_check_a_mundo.F + module_HLaw.F + module_ctrans_aqchem.F + module_random.F + module_interp_nmm.F + module_interp_store.F + module_string_tools.F + module_MPP.F + + module_io_wrf.F + + + module_io_domain.F + + module_optional_input.F + + input_wrf.F + output_wrf.F + wrf_bdyout.F + wrf_bdyin.F + dfi.F + mediation_integrate.F + mediation_wrfmain.F + + solve_interface.F + mediation_interp_domain.F + mediation_force_domain.F + mediation_feedback_domain.F + + start_domain.F + init_modules.F + set_timekeeping.F + interp_fcn.F + sint.F + wrf_ext_write_field.F + wrf_ext_read_field.F + + + wrf_tsin.F + landread.c + track_driver.F + track_input.F + module_trajectory.F + bobrand.c + wrf_timeseries.F + track_driver.F + wrf_fddaobs_in.F + mediation_nest_move.F + setfeenv.c + ) diff --git a/share/mediation_integrate.F b/share/mediation_integrate.F index 98bc99643a..fb12f2eaed 100644 --- a/share/mediation_integrate.F +++ b/share/mediation_integrate.F @@ -1701,6 +1701,8 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & ENDIF ierr = 0 + fname = "" + n2 = "" ! Note that computation of fname and n2 are outside of the oid IF statement ! since they are OUT args and may be used by callers even if oid/=0. diff --git a/share/module_check_a_mundo.F b/share/module_check_a_mundo.F index 1acb3bda82..8ad4e88a6d 100644 --- a/share/module_check_a_mundo.F +++ b/share/module_check_a_mundo.F @@ -504,6 +504,28 @@ END FUNCTION bep_bem_ngr_u END IF ENDDO +!----------------------------------------------------------------------- +! Check that only compatible options are set when slucm_distributed_drag is set +!----------------------------------------------------------------------- + IF (model_config_rec % slucm_distributed_drag) THEN + + IF (model_config_rec % use_wudapt_lcz .EQ. 1) THEN + wrf_err_message = '--- ERROR: slucm_distributed_drag cannot work with use_wudapt_lcz' + CALL wrf_message ( wrf_err_message ) + count_fatal_error = count_fatal_error + 1 + END IF + + DO i = 1, model_config_rec % max_dom + IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE + IF ( model_config_rec % sf_urban_physics(i) > 1 ) THEN + wrf_err_message = '--- ERROR: slucm_distributed_drag only works with urban options 1' + CALL wrf_message ( wrf_err_message ) + count_fatal_error = count_fatal_error + 1 + END IF + END DO + + END IF + !----------------------------------------------------------------------- ! Check that channel irrigation is run with Noah !----------------------------------------------------------------------- @@ -3352,6 +3374,98 @@ SUBROUTINE set_physics_rconfigs END IF +!----------------------------------------------------------------------- +! Check for deprecated options with NSSL-MP +!----------------------------------------------------------------------- + DO i = 1, model_config_rec % max_dom + IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE + IF ( model_config_rec % mp_physics(i) .EQ. 22 ) THEN + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 1 + model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_ccn_on = 0 + model_config_rec % nssl_density_on = 1 ! set graupel density + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 22 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_hail_on=0, nssl_ccn_on=0' + CALL wrf_debug ( 0, wrf_err_message ) + ELSEIF ( model_config_rec % mp_physics(i) .EQ. 17 ) THEN + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 1 + model_config_rec % nssl_hail_on(i) = 1 + model_config_rec % nssl_ccn_on = 0 + model_config_rec % nssl_density_on = 2 ! set graupel+hail density + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 17 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_ccn_on=0' + ! print statement for deprecated option + CALL wrf_debug ( 0, wrf_err_message ) + ELSEIF ( model_config_rec % mp_physics(i) .EQ. 19 ) THEN + ! single-moment with hail + graupel density + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 0 + model_config_rec % nssl_hail_on(i) = 2 + model_config_rec % nssl_density_on = 1 ! set graupel density + ! print statement for deprecated option + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 19 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_2moment_on=0, nssl_ccn_on=0' + CALL wrf_debug ( 0, wrf_err_message ) + ELSEIF ( model_config_rec % mp_physics(i) .EQ. 21 ) THEN + ! single-moment without + model_config_rec % mp_physics(i) = NSSL_2MOM + model_config_rec % nssl_2moment_on = 0 + model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_density_on = 0 ! set graupel density + ! print statement for deprecated option + WRITE (wrf_err_message, FMT='(A)') ' **CAUTION** mp_physics = 21 has been deprecated. '// & + 'Instead you can use mp_physics=18, nssl_2moment_on=0, nssl_ccn_on=0, nssl_hail_on=0' + CALL wrf_debug ( 0, wrf_err_message ) + ENDIF + + IF ( model_config_rec % mp_physics(i) /= NSSL_2MOM ) THEN + ! If not NSSL-MP, make sure extra fields are turned off (in case of stray namelist settings) + model_config_rec % nssl_2moment_on = 0 + model_config_rec % nssl_hail_on(i) = 0 + model_config_rec % nssl_density_on = 0 ! set graupel density + model_config_rec % nssl_3moment = 0 + model_config_rec % nssl_ccn_on = 0 + + ELSE ! make sure settings are consistent + + IF ( model_config_rec % nssl_ccn_on < 0 ) THEN + model_config_rec % nssl_ccn_on = 1 + ENDIF + + IF ( model_config_rec % nssl_2moment_on < 0 ) THEN ! turn on number concentrations + model_config_rec % nssl_2moment_on = 1 + ENDIF + + IF ( model_config_rec % nssl_hail_on(i) < 0 ) THEN + IF ( model_config_rec % nssl_2moment_on == 0 ) THEN + model_config_rec % nssl_hail_on(i) = 2 + ELSE + model_config_rec % nssl_hail_on(i) = 1 + ENDIF + ENDIF + + IF ( model_config_rec % nssl_density_on < 0 ) THEN + IF ( model_config_rec % nssl_hail_on(i) == 1 ) THEN + model_config_rec % nssl_density_on = 2 ! set default of graupel+hail density + ELSE + model_config_rec % nssl_density_on = 1 ! set graupel density (hail off) + ENDIF + ENDIF + + IF ( model_config_rec % nssl_3moment == 1 ) THEN + model_config_rec % nssl_2moment_on = 1 + IF ( model_config_rec % nssl_hail_on(i) == 1 ) THEN + model_config_rec % nssl_3moment = 2 ! 3mom rain, graupel and hail + ELSE + model_config_rec % nssl_3moment = 1 ! 3mom rain and graupel (no hail) + ENDIF + ENDIF + ENDIF + + ENDDO + !----------------------------------------------------------------------- ! If a user requested to compute the radar reflectivity .OR. if this is ! one of the schemes that ALWAYS computes the radar reflectivity, then @@ -3361,16 +3475,11 @@ SUBROUTINE set_physics_rconfigs DO i = 1, model_config_rec % max_dom IF ( .NOT. model_config_rec % grid_allowed(i) ) CYCLE IF ( ( model_config_rec % mp_physics(i) .EQ. MILBRANDT2MOM ) .OR. & -#if (EM_CORE == 1) ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOM ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOMG ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOMCCN ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_1MOM ) .OR. & - ( model_config_rec % mp_physics(i) .EQ. NSSL_1MOMLFO ) .OR. & -#endif ( model_config_rec % do_radar_ref .EQ. 1 ) ) THEN model_config_rec % compute_radar_ref = 1 - END IF + ENDIF + ENDDO !----------------------------------------------------------------------- diff --git a/share/module_model_constants.F b/share/module_model_constants.F index ebb2425ddf..697d2f9486 100644 --- a/share/module_model_constants.F +++ b/share/module_model_constants.F @@ -62,6 +62,9 @@ MODULE module_model_constants REAL , PARAMETER :: RE_QC_BG = 2.49E-6 ! effective radius of cloud for background (m) REAL , PARAMETER :: RE_QI_BG = 4.99E-6 ! effective radius of ice for background (m) REAL , PARAMETER :: RE_QS_BG = 9.99E-6 ! effective radius of snow for background (m) + REAL , PARAMETER :: RE_QC_MAX = 50.E-6 ! max effective radius of cloud allowed + REAL , PARAMETER :: RE_QI_MAX = 125.E-6 ! max effective radius of ice allowed + REAL , PARAMETER :: RE_QS_MAX = 999.E-6 ! max effective radius of snow allowed ! ! Now namelist-specified parameter: ccn_conc - RAS ! REAL , PARAMETER :: n_ccn0 = 1.0E8 diff --git a/share/output_wrf.F b/share/output_wrf.F index 1d07dcf97a..3cec620bc7 100644 --- a/share/output_wrf.F +++ b/share/output_wrf.F @@ -668,6 +668,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', sf_urban_physics , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SF_SURFACE_MOSAIC', config_flags%sf_surface_mosaic , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SF_OCEAN_PHYSICS', config_flags%sf_ocean_physics , 1 , ierr ) + CALL wrf_put_dom_ti_logical ( fid, 'SLUCM_DISTRIBUTED_DRAG', config_flags%slucm_distributed_drag, 1, ierr) + CALL wrf_put_dom_ti_integer ( fid, 'DISTRIBUTED_AHE_OPT', config_flags%distributed_ahe_opt, 1, ierr) #endif IF ( switch .EQ. history_only ) THEN diff --git a/share/wrf_tsin.F b/share/wrf_tsin.F index 0ba9729763..694a05d77e 100644 --- a/share/wrf_tsin.F +++ b/share/wrf_tsin.F @@ -24,12 +24,17 @@ SUBROUTINE wrf_tsin ( grid , ierr ) ierr = 0 + ! + ! If time series locations have already been computed by calc_ts_locations, + ! assume that we have already read the 'tslist' file for this domain and return + ! + IF ( grid%have_calculated_tslocs ) RETURN + #if ((EM_CORE == 1) && (DA_CORE != 1)) IF ( grid%dfi_opt == DFI_NODFI .OR. (grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage == DFI_SETUP) ) THEN #endif CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) grid%ntsloc = 0 - grid%have_calculated_tslocs = .FALSE. IF ( grid%max_ts_locs <= 0 ) RETURN diff --git a/test/em_b_wave/CMakeLists.txt b/test/em_b_wave/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_b_wave/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_convrad/CMakeLists.txt b/test/em_convrad/CMakeLists.txt new file mode 100644 index 0000000000..b362766fab --- /dev/null +++ b/test/em_convrad/CMakeLists.txt @@ -0,0 +1,27 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/run/README.namelist + ${PROJECT_SOURCE_DIR}/run/LANDUSE.TBL + ${PROJECT_SOURCE_DIR}/run/RRTMG_LW_DATA + ${PROJECT_SOURCE_DIR}/run/RRTMG_SW_DATA + ${PROJECT_SOURCE_DIR}/run/ozone.formatted + ${PROJECT_SOURCE_DIR}/run/ozone_lat.formatted + ${PROJECT_SOURCE_DIR}/run/ozone_plev.formatted + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_fire/CMakeLists.txt b/test/em_fire/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_fire/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_fire/namelist.fire.sb40 b/test/em_fire/namelist.fire.sb40 new file mode 100644 index 0000000000..c80b11b1ec --- /dev/null +++ b/test/em_fire/namelist.fire.sb40 @@ -0,0 +1,131 @@ +&fuel_scalars ! scalar fuel constants +cmbcnst = 17.433e+06, ! J/kg combustion heat dry fuel +hfgl = 17.e4 , ! W/m^2 heat flux to ignite canopy +fuelmc_g = 0.08, ! ground fuel moisture, set = 0 for dry +fuelmc_g_lh = 1.20, ! ground live herb fuel moisture, set = 0 for dry +fuelmc_c = 1.00, ! canopy fuel moisture, set = 0 for dry +nfuelcats = 54, ! number of fuel categories used +no_fuel_cat = 14 ! extra category for no fuel +/ + +&fuel_categories + fuel_name = +'1: Short grass (1 ft)', +'2: Timber (grass and understory)', +'3: Tall grass (2.5 ft)', +'4: Chaparral (6 ft)', +'5: Brush (2 ft) ', +'6: Dormant brush, hardwood slash', +'7: Southern rough', +'8: Closed timber litter', +'9: Hardwood litter', +'10: Timber (litter + understory)', +'11: Light logging slash', +'12: Medium logging slash', +'13: Heavy logging slash', +'14: no fuel', +'15: Short, Sparse Dry Climate Grass (Dynamic) [GR1 (101)]', +'16: Low Load, Dry Climate Grass (Dynamic) GR2 (102)', +'17: Low Load, Very Coarse, Humid Climate Grass (Dynamic) [GR3 (103)]', +'18: Moderate Load, Dry Climate Grass (Dynamic) [GR4 (104)]', +'19: Low Load, Humid Climate Grass (Dynamic) [GR5 (105)]', +'20: Moderate Load, Humid Climate Grass (Dynamic) [GR6 (106)]', +'21: High Load, Dry Climate Grass (Dynamic) [GR7 (107)]', +'22: High Load, Very Coarse, Humid Climate Grass (Dynamic) [GR8 (108)]', +'23: Very High Load, Humid Climate Grass (Dynamic) [GR9 (109)]', +'24: Low Load, Dry Climate Grass-Shrub (Dynamic) [GS1 (121)]', +'25: Moderate Load, Dry Climate Grass-Shrub (Dynamic) [GS2 (122)]', +'26: Moderate Load, Humid Climate Grass-Shrub (Dynamic) [GS3 (123)]', +'27: High Load, Humid Climate Grass-Shrub (Dynamic) [GS4 (124)]', +'28: Low Load Dry Climate Shrub (Dynamic) [SH1 (141)]', +'29: Moderate Load Dry Climate Shrub [SH2 (142)]', +'30: Moderate Load, Humid Climate Shrub [SH3 (143)]', +'31: Low Load, Humid Climate Timber-Shrub [SH4 (144)]', +'32: High Load, Dry Climate Shrub [SH5 (145)]', +'33: Low Load, Humid Climate Shrub [SH6 (146)]', +'34: Very High Load, Dry Climate Shrub [SH7 (147)]', +'35: High Load, Humid Climate Shrub [SH8 (148)]', +'36: Very High Load, Humid Climate Shrub (Dynamic) [SH9 (149)]', +'37: Low Load Dry Climate Timber-Grass-Shrub (Dynamic) [TU1 (161)]', +'38: Moderate Load, Humid Climate Timber-Shrub [TU2 (162)]', +'39: Moderate Load, Humid Climate Timber-Grass-Shrub (Dynamic) [TU3 (163)]', +'40: Dwarf Conifer With Understory [TU4 (164)]', +'41: Very High Load, Dry Climate Timber-Shrub [TU5 (165)]', +'42: Low Load Compact Conifer Litter [TL1 (181)]', +'43: Low Load Broadleaf Litter [TL2 (182)]', +'44: Moderate Load Conifer Litter [TL3 (183)]', +'45: Small downed logs [TL4 (184)]', +'46: High Load Conifer Litter [TL5 (185)]', +'47: Moderate Load Broadleaf Litter [TL6 (186)]', +'48: Large Downed Logs [TL7 (187)]', +'49: Long-Needle Litter [TL8 (188)]', +'50: Very High Load Broadleaf Litter [TL9 (189)]', +'51: Low Load Activity Fuel [SB1 (201)]', +'52: Moderate Load Activity Fuel or Low Load Blowdown [SB2 (202)]', +'53: High Load Activity Fuel or Moderate Load Blowdown [SB3 (203)]', +'54: High Load Blowdown [SB4 (204)]' + fgi = 0.1660, 0.8960, 0.6740, 3.5910, 0.7840, 1.3440, 1.0910, 1.1200, 0.7800, 2.6920, 2.5820, 7.7490, 13.0240, 1.e-7, + 0.0224, 0.0224, 0.1121, 0.0560, 0.0897, 0.0224, 0.2242, 0.3363, 0.4483, + 0.0448, 0.2242, 0.1233, 0.5156, + 0.1121, 1.0088, 0.7734, 0.4932, 1.2778, 0.9751, 2.4659, 1.4123, 1.5580, + 0.5828, 0.8967, 0.3363, 1.0088, 2.4659, + 1.5244, 1.3226, 1.2329, 1.3899, 1.8046, 1.0760, 2.1969, 1.8606, 3.1608, + 3.4746, 2.8582, 2.5219, 3.1384 + fgi_lh = 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, + 0.0673, 0.2242, 0.3363, 0.4259, 0.5604, 0.7622, 1.2105, 1.6364, 2.0175, + 0.1121, 0.1345, 0.3250, 0.7622, + 0.0336, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.3475, + 0.0448, 0.0000, 0.1457, 0.0000, 0.0000, + 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, + 0.0000, 0.0000, 0.0000, 0.0000 + fueldepthm= 0.3050, 0.3050, 0.7620, 1.8290, 0.6100, 0.7620, 0.7620, 0.0610, 0.0610, 0.3050, 0.3050, 0.7010, 0.9140, 0.3050, + 0.1219, 0.3048, 0.6096, 0.6096, 0.4572, 0.4572, 0.9144, 1.2192, 1.5240, + 0.2743, 0.4572, 0.5486, 0.6401, + 0.3048, 0.3048, 0.7315, 0.9144, 1.8288, 0.6096, 1.8288, 0.9144, 1.3411, + 0.1829, 0.3048, 0.3962, 0.1524, 0.3048, + 0.0610, 0.0610, 0.0914, 0.1219, 0.1829, 0.0914, 0.1219, 0.0914, 0.1829, + 0.3048, 0.3048, 0.3658, 0.8230 + savr = 3500., 2784., 1500., 1739., 1683., 1564., 1562., 1889., 2484., 1764., 1182., 1145., 1159., 3500., + 2200., 2000., 1500., 2000., 1800., 2200., 2000., 1500., 1800., + 2000., 2000., 1800., 1800., + 2000., 2000., 1600., 2000., 750., 750., 750., 750., 750., + 2000., 2000., 1800., 2300., 1500., + 2000., 2000., 2000., 2000., 2000., 2000., 2000., 1800., 1800., + 2000., 2000., 2000., 2000. + fuelmce = 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12, + 0.15, 0.15, 0.30, 0.15, 0.40, 0.40, 0.15, 0.30, 0.40, + 0.15, 0.15, 0.40, 0.40, + 0.15, 0.15, 0.40, 0.30, 0.15, 0.30, 0.15, 0.40, 0.40, + 0.20, 0.30, 0.30, 0.12, 0.25, + 0.30, 0.25, 0.20, 0.25, 0.25, 0.25, 0.25, 0.35, 0.35, + 0.25, 0.25, 0.25, 0.25 + fueldens = 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., ! 32 if solid, 19 if rotten + 32., 32., 32., 32., 32., 32., 32., 32., 32., + 32., 32., 32., 32., + 32., 32., 32., 32., 32., 32., 32., 32., 32., + 32., 32., 32., 32., 32., + 32., 32., 32., 32., 32., 32., 32., 32., 32., + 32., 32., 32., 32. + st = 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555 + se = 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010 + ! ----- Notes on weight: (4) - best fit of Latham data; (5)-(7) could be 60-120; (8)-(10) could be 300-1600; (11)-(13) could be 300-1600 + weight = 7., 7., 7., 180., 100., 100., 100., 900., 900., 900., 900., 900., 900., 7., + 7., 7., 7., 7., 7., 7., 7., 7., 7., + 7., 7., 7., 7., + 100., 100., 100., 100., 180., 100., 180., 100., 100., + 900., 900., 900., 900., 900., + 900., 900., 900., 900., 900., 900., 900., 900., 900., + 900., 900., 900., 900. + / diff --git a/test/em_fire/namelist.fire_fmc.sb40 b/test/em_fire/namelist.fire_fmc.sb40 new file mode 100644 index 0000000000..2ea79a7d49 --- /dev/null +++ b/test/em_fire/namelist.fire_fmc.sb40 @@ -0,0 +1,191 @@ +&fuel_scalars ! scalar fuel constants +cmbcnst = 17.433e+06, ! J/kg combustion heat dry fuel +hfgl = 17.e4 , ! W/m^2 heat flux to ignite canopy +fuelmc_g = 0.08, ! ground fuel moisture, set = 0 for dry +fuelmc_g_lh = 1.20, ! ground live herb fuel moisture, set = 0 for dry +fuelmc_c = 1.00, ! canopy fuel moisture, set = 0 for dry +nfuelcats = 54, ! number of fuel categories used +no_fuel_cat = 14 ! extra category for no fuel +/ + +&fuel_categories + fuel_name = +'1: Short grass (1 ft)', +'2: Timber (grass and understory)', +'3: Tall grass (2.5 ft)', +'4: Chaparral (6 ft)', +'5: Brush (2 ft) ', +'6: Dormant brush, hardwood slash', +'7: Southern rough', +'8: Closed timber litter', +'9: Hardwood litter', +'10: Timber (litter + understory)', +'11: Light logging slash', +'12: Medium logging slash', +'13: Heavy logging slash', +'14: no fuel', +'15: Short, Sparse Dry Climate Grass (Dynamic) [GR1 (101)]', +'16: Low Load, Dry Climate Grass (Dynamic) GR2 (102)', +'17: Low Load, Very Coarse, Humid Climate Grass (Dynamic) [GR3 (103)]', +'18: Moderate Load, Dry Climate Grass (Dynamic) [GR4 (104)]', +'19: Low Load, Humid Climate Grass (Dynamic) [GR5 (105)]', +'20: Moderate Load, Humid Climate Grass (Dynamic) [GR6 (106)]', +'21: High Load, Dry Climate Grass (Dynamic) [GR7 (107)]', +'22: High Load, Very Coarse, Humid Climate Grass (Dynamic) [GR8 (108)]', +'23: Very High Load, Humid Climate Grass (Dynamic) [GR9 (109)]', +'24: Low Load, Dry Climate Grass-Shrub (Dynamic) [GS1 (121)]', +'25: Moderate Load, Dry Climate Grass-Shrub (Dynamic) [GS2 (122)]', +'26: Moderate Load, Humid Climate Grass-Shrub (Dynamic) [GS3 (123)]', +'27: High Load, Humid Climate Grass-Shrub (Dynamic) [GS4 (124)]', +'28: Low Load Dry Climate Shrub (Dynamic) [SH1 (141)]', +'29: Moderate Load Dry Climate Shrub [SH2 (142)]', +'30: Moderate Load, Humid Climate Shrub [SH3 (143)]', +'31: Low Load, Humid Climate Timber-Shrub [SH4 (144)]', +'32: High Load, Dry Climate Shrub [SH5 (145)]', +'33: Low Load, Humid Climate Shrub [SH6 (146)]', +'34: Very High Load, Dry Climate Shrub [SH7 (147)]', +'35: High Load, Humid Climate Shrub [SH8 (148)]', +'36: Very High Load, Humid Climate Shrub (Dynamic) [SH9 (149)]', +'37: Low Load Dry Climate Timber-Grass-Shrub (Dynamic) [TU1 (161)]', +'38: Moderate Load, Humid Climate Timber-Shrub [TU2 (162)]', +'39: Moderate Load, Humid Climate Timber-Grass-Shrub (Dynamic) [TU3 (163)]', +'40: Dwarf Conifer With Understory [TU4 (164)]', +'41: Very High Load, Dry Climate Timber-Shrub [TU5 (165)]', +'42: Low Load Compact Conifer Litter [TL1 (181)]', +'43: Low Load Broadleaf Litter [TL2 (182)]', +'44: Moderate Load Conifer Litter [TL3 (183)]', +'45: Small downed logs [TL4 (184)]', +'46: High Load Conifer Litter [TL5 (185)]', +'47: Moderate Load Broadleaf Litter [TL6 (186)]', +'48: Large Downed Logs [TL7 (187)]', +'49: Long-Needle Litter [TL8 (188)]', +'50: Very High Load Broadleaf Litter [TL9 (189)]', +'51: Low Load Activity Fuel [SB1 (201)]', +'52: Moderate Load Activity Fuel or Low Load Blowdown [SB2 (202)]', +'53: High Load Activity Fuel or Moderate Load Blowdown [SB3 (203)]', +'54: High Load Blowdown [SB4 (204)]' + fgi = 0.1660, 0.8960, 0.6740, 3.5910, 0.7840, 1.3440, 1.0910, 1.1200, 0.7800, 2.6920, 2.5820, 7.7490, 13.0240, 1.e-7, + 0.0224, 0.0224, 0.1121, 0.0560, 0.0897, 0.0224, 0.2242, 0.3363, 0.4483, + 0.0448, 0.2242, 0.1233, 0.5156, + 0.1121, 1.0088, 0.7734, 0.4932, 1.2778, 0.9751, 2.4659, 1.4123, 1.5580, + 0.5828, 0.8967, 0.3363, 1.0088, 2.4659, + 1.5244, 1.3226, 1.2329, 1.3899, 1.8046, 1.0760, 2.1969, 1.8606, 3.1608, + 3.4746, 2.8582, 2.5219, 3.1384 + fgi_lh = 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, + 0.0673, 0.2242, 0.3363, 0.4259, 0.5604, 0.7622, 1.2105, 1.6364, 2.0175, + 0.1121, 0.1345, 0.3250, 0.7622, + 0.0336, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.3475, + 0.0448, 0.0000, 0.1457, 0.0000, 0.0000, + 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, + 0.0000, 0.0000, 0.0000, 0.0000 + fueldepthm= 0.3050, 0.3050, 0.7620, 1.8290, 0.6100, 0.7620, 0.7620, 0.0610, 0.0610, 0.3050, 0.3050, 0.7010, 0.9140, 0.3050, + 0.1219, 0.3048, 0.6096, 0.6096, 0.4572, 0.4572, 0.9144, 1.2192, 1.5240, + 0.2743, 0.4572, 0.5486, 0.6401, + 0.3048, 0.3048, 0.7315, 0.9144, 1.8288, 0.6096, 1.8288, 0.9144, 1.3411, + 0.1829, 0.3048, 0.3962, 0.1524, 0.3048, + 0.0610, 0.0610, 0.0914, 0.1219, 0.1829, 0.0914, 0.1219, 0.0914, 0.1829, + 0.3048, 0.3048, 0.3658, 0.8230 + savr = 3500., 2784., 1500., 1739., 1683., 1564., 1562., 1889., 2484., 1764., 1182., 1145., 1159., 3500., + 2200., 2000., 1500., 2000., 1800., 2200., 2000., 1500., 1800., + 2000., 2000., 1800., 1800., + 2000., 2000., 1600., 2000., 750., 750., 750., 750., 750., + 2000., 2000., 1800., 2300., 1500., + 2000., 2000., 2000., 2000., 2000., 2000., 2000., 1800., 1800., + 2000., 2000., 2000., 2000. + fuelmce = 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12, + 0.15, 0.15, 0.30, 0.15, 0.40, 0.40, 0.15, 0.30, 0.40, + 0.15, 0.15, 0.40, 0.40, + 0.15, 0.15, 0.40, 0.30, 0.15, 0.30, 0.15, 0.40, 0.40, + 0.20, 0.30, 0.30, 0.12, 0.25, + 0.30, 0.25, 0.20, 0.25, 0.25, 0.25, 0.25, 0.35, 0.35, + 0.25, 0.25, 0.25, 0.25 + fueldens = 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., 32., ! 32 if solid, 19 if rotten + 32., 32., 32., 32., 32., 32., 32., 32., 32., + 32., 32., 32., 32., + 32., 32., 32., 32., 32., 32., 32., 32., 32., + 32., 32., 32., 32., 32., + 32., 32., 32., 32., 32., 32., 32., 32., 32., + 32., 32., 32., 32. + st = 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, 0.0555, + 0.0555, 0.0555, 0.0555, 0.0555 + se = 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + 0.010, 0.010, 0.010, 0.010 + ! ----- Notes on weight: (4) - best fit of Latham data; (5)-(7) could be 60-120; (8)-(10) could be 300-1600; (11)-(13) could be 300-1600 + weight = 7., 7., 7., 180., 100., 100., 100., 900., 900., 900., 900., 900., 900., 7., + 7., 7., 7., 7., 7., 7., 7., 7., 7., + 7., 7., 7., 7., + 100., 100., 100., 100., 180., 100., 180., 100., 100., + 900., 900., 900., 900., 900., + 900., 900., 900., 900., 900., 900., 900., 900., 900., + 900., 900., 900., 900. + +! fuel loading 1-h, 10-h, 100-h, 1000-h, live following Albini 1976 as reprinted in Anderson 1982 Table 1 +! for relative proportions between classes only +! TWJ added values for S&B model in corresponding rows +! 1 2 3 4 5 6 7 8 9 10 11 12 13 + fgi_1h = 0.74, 2.00, 3.01, 5.01, 1.00, 1.50, 1.13, 1.50, 2.92, 3.01, 1.50, 4.01, 7.01, + 0.10, 0.10, 0.10, 0.25, 0.40, 0.10, 1.00, 0.50, 1.00, + 0.20, 0.50, 0.30, 1.90, + 0.25, 1.35, 0.45, 0.85, 3.60, 2.90, 3.50, 2.05, 4.50, + 0.20, 0.95, 1.10, 4.50, 4.00, + 1.00, 1.40, 0.50, 0.50, 1.15, 2.40, 0.30, 5.80, 6.65, + 1.50, 4.50, 5.50, 5.25 + fgi_10h = 0.000, 1.00, 0.00, 4.01, 0.50, 2.50, 1.87, 1.00, 0.41, 2.00, 4.51, 14.03, 23.04, + 0.00, 0.00, 0.40, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, + 0.00, 0.50, 0.25, 0.30, + 0.25, 2.40, 3.00, 1.15, 2.10, 1.45, 5.30, 3.40, 2.45, + 0.90, 1.80, 0.15, 0.00, 4.00, + 2.20, 2.30, 2.20, 1.50, 2.50, 1.20, 1.40, 1.40, 3.30, + 3.00, 4.25, 2.75, 3.50 + fgi_100h = 0.000, 0.50, 0.00, 2.00, 0.00, 2.00, 1.50, 2.50, 0.15, 5.01, 5.51, 16.53, 28.05, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.10, + 0.00, 0.75, 0.00, 0.20, 0.00, 0.00, 2.20, 0.85, 0.00, + 1.50, 1.25, 0.25, 0.00, 3.00, + 3.60, 2.20, 2.80, 4.20, 4.40, 1.20, 8.10, 1.10, 4.15, + 11.00, 4.00, 3.00, 5.25 + fgi_1000h = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00 + fgi_live = 0.000, 0.50, 0.000, 5.01, 2.00, 0.00, 0.37, 0.00, 0.00, 2.00, 0.00, 2.3, 0.00, + 0.30, 1.00, 1.50, 1.90, 2.50, 3.40, 5.40, 7.30, 9.00, + 0.50, 0.60, 1.45, 3.40, + 0.15, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.55, + 0.20, 0.00, 0.65, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00 + / + +&fuel_moisture +! Fuel moisture model coefficients to experiment with different models. +! Can be omitted, then the defaults in the code are used. +moisture_classes = 5, +moisture_class_name= '1-h','10-h','100-h','1000-h','Live', ! identification to be printed +drying_model= 1, 1, 1, 1, 1, ! number of model - only 1= equilibrium moisture Van Wagner (1972) per Viney (1991) allowed +drying_lag= 1, 10, 100, 1000, 1e9, ! so-called 10hr and 100hr fuel +wetting_model= 1, 1, 1, 1, 1, ! number of model - only 1= allowed at this moment +wetting_lag= 1.4, 14.0, 140.0, 1400.0, 1e9, ! 10-h lag callibrated to VanWagner&Pickett 1985, Canadian fire danger rating system, rest by scaling +saturation_moisture= 2.5, 2.5, 2.5, 2.5, 2.5, ! ditto +saturation_rain = 8.0, 8.0, 8.0, 8.0, 8.0, ! stronger rain than this (mm/h) does not make much difference. +rain_threshold = 0.05, 0.05, 0.05, 0.05, 0.05,! mm/h rain too weak to wet anything. +fmc_gc_initialization= 2, 2, 2, 2, 3,! 0: from wrfinput, 1:from fuelmc_g, 2: from equilibrium, 3: from fmc_1h,...,fmc_live +fmc_1h = 0.08, ! as in fuelmc_g, used only if fmc_gc_initialization(1) = 3 +fmc_10h = 0.08, ! as in fuelmc_g, used only if fmc_gc_initialization(2) = 3 +fmc_100h = 0.08, ! as in fuelmc_g, used only if fmc_gc_initialization(3) = 3 +fmc_1000h = 0.08, ! as in fuelmc_g, used only if fmc_gc_initialization(4) = 3 +fmc_live = 0.30, ! Completely cured, used only if fmc_gc_initialization(5) = 3 +/ diff --git a/test/em_grav2d_x/CMakeLists.txt b/test/em_grav2d_x/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_grav2d_x/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_heldsuarez/CMakeLists.txt b/test/em_heldsuarez/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_heldsuarez/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_hill2d_x/CMakeLists.txt b/test/em_hill2d_x/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_hill2d_x/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_les/CMakeLists.txt b/test/em_les/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_les/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_quarter_ss/CMakeLists.txt b/test/em_quarter_ss/CMakeLists.txt new file mode 100644 index 0000000000..54ffc652fc --- /dev/null +++ b/test/em_quarter_ss/CMakeLists.txt @@ -0,0 +1,31 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/run/README.namelist + ${PROJECT_SOURCE_DIR}/run/bulkdens.asc_s_0_03_0_9 + ${PROJECT_SOURCE_DIR}/run/bulkradii.asc_s_0_03_0_9 + ${PROJECT_SOURCE_DIR}/run/capacity.asc + ${PROJECT_SOURCE_DIR}/run/coeff_p.asc + ${PROJECT_SOURCE_DIR}/run/coeff_q.asc + ${PROJECT_SOURCE_DIR}/run/constants.asc + ${PROJECT_SOURCE_DIR}/run/kernels.asc_s_0_03_0_9 + ${PROJECT_SOURCE_DIR}/run/kernels_z.asc + ${PROJECT_SOURCE_DIR}/run/masses.asc + ${PROJECT_SOURCE_DIR}/run/termvels.asc + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_real/CMakeLists.txt b/test/em_real/CMakeLists.txt new file mode 100644 index 0000000000..d68270361a --- /dev/null +++ b/test/em_real/CMakeLists.txt @@ -0,0 +1,126 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS real tc ndown wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/run/README.namelist + ${PROJECT_SOURCE_DIR}/run/README.physics_files + ${PROJECT_SOURCE_DIR}/run/README.physics_files + + ${PROJECT_SOURCE_DIR}/run/ETAMPNEW_DATA + ${PROJECT_SOURCE_DIR}/run/ETAMPNEW_DATA.expanded_rain + ${PROJECT_SOURCE_DIR}/run/RRTM_DATA + ${PROJECT_SOURCE_DIR}/run/RRTMG_LW_DATA + ${PROJECT_SOURCE_DIR}/run/RRTMG_SW_DATA + ${PROJECT_SOURCE_DIR}/run/CAM_ABS_DATA + ${PROJECT_SOURCE_DIR}/run/CAM_AEROPT_DATA + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.RCP4.5 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.RCP6 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.RCP8.5 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.A1B + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.A2 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP119 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP126 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP245 + #!TODO Why does this have an alt name? + # ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP245 # Has alt name, why? + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP370 + ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP585 + ${PROJECT_SOURCE_DIR}/run/CLM_ALB_ICE_DFS_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_ALB_ICE_DRC_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_ASM_ICE_DFS_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_ASM_ICE_DRC_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_DRDSDT0_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_EXT_ICE_DFS_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_EXT_ICE_DRC_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_KAPPA_DATA + ${PROJECT_SOURCE_DIR}/run/CLM_TAU_DATA + ${PROJECT_SOURCE_DIR}/run/ozone.formatted + ${PROJECT_SOURCE_DIR}/run/ozone_lat.formatted + ${PROJECT_SOURCE_DIR}/run/ozone_plev.formatted + ${PROJECT_SOURCE_DIR}/run/aerosol.formatted + ${PROJECT_SOURCE_DIR}/run/aerosol_lat.formatted + ${PROJECT_SOURCE_DIR}/run/aerosol_lon.formatted + ${PROJECT_SOURCE_DIR}/run/aerosol_plev.formatted + ${PROJECT_SOURCE_DIR}/run/eclipse_besselian_elements.dat + ${PROJECT_SOURCE_DIR}/run/capacity.asc + ${PROJECT_SOURCE_DIR}/run/coeff_p.asc + ${PROJECT_SOURCE_DIR}/run/coeff_q.asc + ${PROJECT_SOURCE_DIR}/run/constants.asc + ${PROJECT_SOURCE_DIR}/run/masses.asc + ${PROJECT_SOURCE_DIR}/run/termvels.asc + ${PROJECT_SOURCE_DIR}/run/kernels.asc_s_0_03_0_9 + ${PROJECT_SOURCE_DIR}/run/kernels_z.asc + ${PROJECT_SOURCE_DIR}/run/bulkdens.asc_s_0_03_0_9 + ${PROJECT_SOURCE_DIR}/run/bulkradii.asc_s_0_03_0_9 + ${PROJECT_SOURCE_DIR}/run/CCN_ACTIVATE.BIN + ${PROJECT_SOURCE_DIR}/run/p3_lookupTable_1.dat-v5.4_2momI + ${PROJECT_SOURCE_DIR}/run/p3_lookupTable_1.dat-v5.4_3momI + ${PROJECT_SOURCE_DIR}/run/p3_lookupTable_2.dat-v5.3 + ${PROJECT_SOURCE_DIR}/run/HLC.TBL + ${PROJECT_SOURCE_DIR}/run/wind-turbine-1.tbl + ${PROJECT_SOURCE_DIR}/run/ishmael-gamma-tab.bin + ${PROJECT_SOURCE_DIR}/run/ishmael-qi-qc.bin + ${PROJECT_SOURCE_DIR}/run/ishmael-qi-qr.bin + ${PROJECT_SOURCE_DIR}/run/BROADBAND_CLOUD_GODDARD.bin + ${PROJECT_SOURCE_DIR}/run/STOCHPERT.TBL + + ${PROJECT_SOURCE_DIR}/run/GENPARM.TBL + ${PROJECT_SOURCE_DIR}/run/LANDUSE.TBL + ${PROJECT_SOURCE_DIR}/run/SOILPARM.TBL + ${PROJECT_SOURCE_DIR}/run/URBPARM.TBL + ${PROJECT_SOURCE_DIR}/run/URBPARM_LCZ.TBL + ${PROJECT_SOURCE_DIR}/run/VEGPARM.TBL + ${PROJECT_SOURCE_DIR}/phys/noahmp/parameters/MPTABLE.TBL + ${PROJECT_SOURCE_DIR}/run/tr49t67 + ${PROJECT_SOURCE_DIR}/run/tr49t85 + ${PROJECT_SOURCE_DIR}/run/tr67t85 + ${PROJECT_SOURCE_DIR}/run/gribmap.txt + ${PROJECT_SOURCE_DIR}/run/grib2map.tbl + DEST_PATH + ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) + +wrf_setup_file_new_name( + FILE ${PROJECT_SOURCE_DIR}/run/CAMtr_volume_mixing_ratio.SSP245 + NEW_NAME ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST}/CAMtr_volume_mixing_ratio + USE_SYMLINKS + ) + + +if ( ${USE_DOUBLE} ) + + wrf_setup_file_new_name( + FILE ${PROJECT_SOURCE_DIR}/run/ETAMPNEW_DATA_DBL + NEW_NAME ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST}/ETAMPNEW_DATA + ) + wrf_setup_file_new_name( + FILE ${PROJECT_SOURCE_DIR}/run/ETAMPNEW_DATA.expanded_rain_DBL + NEW_NAME ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST}/ETAMPNEW_DATA.expanded_rain + ) + wrf_setup_file_new_name( + FILE ${PROJECT_SOURCE_DIR}/run/RRTM_DATA_DBL + NEW_NAME ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST}/RRTM_DATA + ) + wrf_setup_file_new_name( + FILE ${PROJECT_SOURCE_DIR}/run/RRTMG_LW_DATA_DBL + NEW_NAME ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST}/RRTMG_LW_DATA + ) + wrf_setup_file_new_name( + FILE ${PROJECT_SOURCE_DIR}/run/RRTMG_SW_DATA_DBL + NEW_NAME ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST}/RRTMG_SW_DATA + ) +endif() diff --git a/test/em_scm_xy/CMakeLists.txt b/test/em_scm_xy/CMakeLists.txt new file mode 100644 index 0000000000..fad4a9b122 --- /dev/null +++ b/test/em_scm_xy/CMakeLists.txt @@ -0,0 +1,26 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/run/README.namelist + ${PROJECT_SOURCE_DIR}/run/GENPARM.TBL + ${PROJECT_SOURCE_DIR}/run/LANDUSE.TBL + ${PROJECT_SOURCE_DIR}/run/SOILPARM.TBL + ${PROJECT_SOURCE_DIR}/run/VEGPARM.TBL + ${PROJECT_SOURCE_DIR}/run/RRTM_DATA + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_seabreeze2d_x/CMakeLists.txt b/test/em_seabreeze2d_x/CMakeLists.txt new file mode 100644 index 0000000000..00e2c6c7a7 --- /dev/null +++ b/test/em_seabreeze2d_x/CMakeLists.txt @@ -0,0 +1,23 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/run/README.namelist + ${PROJECT_SOURCE_DIR}/run/LANDUSE.TBL + ${PROJECT_SOURCE_DIR}/run/RRTM_DATA + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_squall2d_x/CMakeLists.txt b/test/em_squall2d_x/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_squall2d_x/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_squall2d_y/CMakeLists.txt b/test/em_squall2d_y/CMakeLists.txt new file mode 100644 index 0000000000..1fdecccc5e --- /dev/null +++ b/test/em_squall2d_y/CMakeLists.txt @@ -0,0 +1,20 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES ${PROJECT_SOURCE_DIR}/run/README.namelist + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/test/em_tropical_cyclone/CMakeLists.txt b/test/em_tropical_cyclone/CMakeLists.txt new file mode 100644 index 0000000000..f7422e0971 --- /dev/null +++ b/test/em_tropical_cyclone/CMakeLists.txt @@ -0,0 +1,22 @@ +# These are just rules for this case, could be named CMakeLists.txt or something +# like install_rules.cmake, whatever you want really +get_filename_component( FOLDER_DEST ${CMAKE_CURRENT_SOURCE_DIR} NAME ) + +install( + DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + DESTINATION ${CMAKE_INSTALL_PREFIX}/test/ + PATTERN CMakeLists.txt EXCLUDE + PATTERN .gitignore EXCLUDE + ) +wrf_setup_targets( + TARGETS ideal wrf + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + USE_SYMLINKS + ) + +wrf_setup_files( + FILES + ${PROJECT_SOURCE_DIR}/run/README.namelist + ${PROJECT_SOURCE_DIR}/run/LANDUSE.TBL + DEST_PATH ${CMAKE_INSTALL_PREFIX}/test/${FOLDER_DEST} + ) \ No newline at end of file diff --git a/tools/CMakeLists.txt b/tools/CMakeLists.txt new file mode 100644 index 0000000000..1181ab0af4 --- /dev/null +++ b/tools/CMakeLists.txt @@ -0,0 +1,142 @@ +# WRF CMake Build + +#!TODO ORGANIZE THIS FOLDER +set( FOLDER_COMPILE_TARGET registry ) + +add_executable( + ${FOLDER_COMPILE_TARGET} + ) + +set( GEN_COMMS gen_comms.stub ) +if ( ${USE_RSL_LITE} ) + message( STATUS "Setting gen_comms to RSL_LITE" ) + set( GEN_COMMS ${PROJECT_SOURCE_DIR}/external/RSL_LITE/gen_comms.c ) +else() + # Account for the weird makefile nonsense of copying things around + set_source_files_properties( + gen_comms.stub + TARGET_DIRECTORY ${FOLDER_COMPILE_TARGET} + PROPERTIES + LANGUAGE C + ) +endif() + +target_sources( + ${FOLDER_COMPILE_TARGET} + PRIVATE + registry.c + my_strtok.c + reg_parse.c + data.c + type.c + misc.c + gen_defs.c + gen_allocs.c + gen_mod_state_descr.c + gen_scalar_indices.c + gen_args.c + gen_config.c + sym.c + symtab_gen.c + gen_irr_diag.c + gen_model_data_ord.c + gen_interp.c + # gen_comms.c + ${GEN_COMMS} + gen_scalar_derefs.c + set_dim_strs.c + gen_wrf_io.c + gen_streams.c + ) + +# set_target_properties( +# ${FOLDER_COMPILE_TARGET} +# PROPERTIES +# Fortran_MODULE_DIRECTORY ${CMAKE_INSTALL_PREFIX}/${FOLDER_COMPILE_TARGET} +# Fortran_FORMAT FREE +# ) + +target_include_directories( ${FOLDER_COMPILE_TARGET} + PRIVATE + ${CMAKE_CURRENT_SOURCE_DIR} + ) + +install( + TARGETS ${FOLDER_COMPILE_TARGET} + RUNTIME DESTINATION bin/ + ARCHIVE DESTINATION lib/ + LIBRARY DESTINATION lib/ + ) + +# Extra stuff for weird registry stuff +set( REGISTRY_FILE "NO_REGISTRY_FILE_SET" ) +if ( ${WRF_CORE} STREQUAL "ARW" ) + + if ( ${ENABLE_CHEM} ) + set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.EM_CHEM ) + + # This check does nothing + # elseif ( ${WRF_DFI_RADAR} ) + # set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.EM ) + + else() + set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.EM ) + + endif() + +elseif ( ${WRF_CORE} STREQUAL "PLUS" ) + set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.tladj ) + +elseif ( ${WRF_CORE} STREQUAL "CONVERT" ) + set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.CONVERT ) + +elseif ( ${WRF_CORE} STREQUAL "DA" OR ${WRF_CORE} STREQUAL "DA_4D_VAR" ) + if ( ${WRF_CHEM} ) + set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.wrfchemvar ) + else() + set( REGISTRY_FILE ${PROJECT_SOURCE_DIR}/Registry/Registry.wrfvar ) + endif() + +endif() + +get_directory_property( DIR_DEFS DIRECTORY ${CMAKE_SOURCE_DIR} COMPILE_DEFINITIONS ) +wrf_expand_definitions( + RESULT_VAR REGISTRY_DEFS + DEFINITIONS ${DIR_DEFS} + ) + +# How this is not a bigger thing or not resolved is beyond me +# https://gitlab.kitware.com/cmake/cmake/-/issues/18005 +# Also the suggestion does not work +add_custom_command( + OUTPUT + ${CMAKE_BINARY_DIR}/inc/nl_config.inc + ${CMAKE_BINARY_DIR}/frame/module_state_description.F + WORKING_DIRECTORY + ${CMAKE_BINARY_DIR} + # Replicate what exists in project directory for registry + COMMAND + ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/Registry + COMMAND + ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/inc + COMMAND + ${CMAKE_COMMAND} -E make_directory ${CMAKE_BINARY_DIR}/frame + COMMAND + ${CMAKE_BINARY_DIR}/tools/registry ${REGISTRY_DEFS} -DNEW_BDYS ${REGISTRY_FILE} > ${CMAKE_BINARY_DIR}/registry.log 2>&1 + #!TODO Just have the registry code actually check for failure or better yet rewrite the + # registry code to not be so obfuscating + COMMAND + ${CMAKE_COMMAND} -E compare_files ${CMAKE_BINARY_DIR}/inc/nl_config.inc ${CMAKE_BINARY_DIR}/inc/nl_config.inc + DEPENDS + ${FOLDER_COMPILE_TARGET} + ) + + + +add_custom_target( + registry_code + DEPENDS + ${CMAKE_BINARY_DIR}/inc/nl_config.inc + ${CMAKE_BINARY_DIR}/frame/module_state_description.F + ) + diff --git a/tools/CodeBase/CMakeLists.txt b/tools/CodeBase/CMakeLists.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tools/Makefile b/tools/Makefile index a2c0acf50b..d413feeb71 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -3,7 +3,7 @@ CC_TOOLS = cc CFLAGS = $(CC_TOOLS_CFLAGS) #-ansi LDFLAGS = -DEBUG = -g +DEBUG = -O0 -g OBJ = registry.o my_strtok.o reg_parse.o data.o type.o misc.o \ gen_defs.o gen_allocs.o gen_mod_state_descr.o gen_scalar_indices.o \ gen_args.o gen_config.o sym.o symtab_gen.o gen_irr_diag.o \ diff --git a/tools/fseek_test.c b/tools/fseek_test.c index edd25c6035..c1bee099b5 100644 --- a/tools/fseek_test.c +++ b/tools/fseek_test.c @@ -1,4 +1,7 @@ #define _FILE_OFFSET_BITS 64 +#ifndef FILE_TO_TEST +#define FILE_TO_TEST "Makefile" +#endif #include #include #include @@ -18,7 +21,7 @@ main() int result2 ; #endif fp = NULL ; - fp = fopen( "Makefile" , "r" ) ; + fp = fopen( FILE_TO_TEST , "r" ) ; #ifdef TEST_FSEEKO x = 0xffffffff ; result1 = (sizeof(x) == 8) ; diff --git a/tools/gen_allocs.c b/tools/gen_allocs.c index c7e7953257..abafbcb893 100644 --- a/tools/gen_allocs.c +++ b/tools/gen_allocs.c @@ -659,7 +659,7 @@ gen_dealloc2 ( FILE * fp , char * structname , node_t * node ) fprintf(fp, " DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s. ')\n endif\n", structname, fname, structname, fname ) ; -#ifdef USE_ALLOCATABLES +#ifndef USE_ALLOCATABLES fprintf(fp, " NULLIFY(%s%s)\n",structname, fname ) ; #endif diff --git a/tools/gen_config.c b/tools/gen_config.c index fc6573975f..c07be2e919 100644 --- a/tools/gen_config.c +++ b/tools/gen_config.c @@ -5,6 +5,7 @@ #include "registry.h" #include "data.h" #include +#include #ifndef _WIN32 # include #endif diff --git a/tools/gen_interp.c b/tools/gen_interp.c index a4a504228c..e2a49ae914 100644 --- a/tools/gen_interp.c +++ b/tools/gen_interp.c @@ -377,7 +377,7 @@ fprintf(fp," ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio strcpy( tmpstr , pp->interpu_aux_fields ) ; } else if ( down_path & FORCE_DOWN ) { /* by default, add the boundary and boundary tendency fields to the arg list */ - if ( ! p->node_kind & FOURD ) { + if ( (! p->node_kind) & FOURD ) { sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name ) ; } else { sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name ) ; @@ -546,8 +546,8 @@ gen_nest_interp2 ( FILE * fp , node_t * node, char * fourdname, int down_path , set_dim_strs2 ( p , ddim , mdim , pdim , "", 1 ) ; } if ( !strcmp ( ddim[0][1], "kde") || - ( ddim[1][1], "kde") || - ( ddim[2][1], "kde")) { + !strcmp ( ddim[1][1], "kde") || + !strcmp ( ddim[2][1], "kde")) { if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; } else { sprintf(tag,"") ; sprintf(tag2,"") ; } diff --git a/tools/gen_irr_diag.c b/tools/gen_irr_diag.c index 40c4219450..048ab53af2 100644 --- a/tools/gen_irr_diag.c +++ b/tools/gen_irr_diag.c @@ -5,6 +5,7 @@ #include #include #include +#include int nChmOpts = 0; char rxt_tbl[5][1000][128]; @@ -254,12 +255,12 @@ int irr_diag_scalar_indices( char *dirname ) strcat( line,piece ); } strcat( line," /)\n" ); - fprintf( fp_inc,line ); + fprintf( fp_inc,"%s",line ); fprintf( fp_inc," \n"); for( i = 0; i < nChmOpts; i++ ) { sprintf( line," chm_opts_name(%d) = '%s'\n",i+1,chm_scheme[i]); - fprintf( fp_inc,line ); + fprintf( fp_inc,"%s",line ); } fprintf( fp_inc," \n"); @@ -272,10 +273,10 @@ int irr_diag_scalar_indices( char *dirname ) strcat( line,piece ); } strcat( line," /)\n" ); - fprintf( fp_inc,line ); + fprintf( fp_inc,"%s",line ); fprintf( fp_inc," \n"); - for( i = 0; i < nChmOpts,rxt_cnt[i] > 0; i++ ) { + for( i = 0; i < nChmOpts && rxt_cnt[i] > 0; i++ ) { for( j = 0; j < rxt_cnt[i]; j++ ) { sprintf( line," rxtsym(%d,%d) = '%s'\n",j+1,i+1,rxt_tbl[i][j]); fprintf( fp_inc,"%s",line); diff --git a/tools/gen_streams.c b/tools/gen_streams.c index f93cf3989d..ad5251ff4d 100644 --- a/tools/gen_streams.c +++ b/tools/gen_streams.c @@ -539,6 +539,7 @@ gen_shutdown_closes ( FILE *fp ) } /* generate the calls that main/wrf_ESMFMod.F uses in wrf_state_populate() */ +int gen_med_open_esmf_calls ( FILE *fp ) { int i ; @@ -569,6 +570,7 @@ gen_med_open_esmf_calls ( FILE *fp ) } /* generate the calls that main/wrf_ESMFMod.F uses in wrf_state_populate() */ +int gen_med_find_esmf_coupling ( FILE *fp ) { int i ; diff --git a/tools/gen_wrf_io.c b/tools/gen_wrf_io.c index 87c539b6e0..d228f6c962 100644 --- a/tools/gen_wrf_io.c +++ b/tools/gen_wrf_io.c @@ -85,7 +85,7 @@ gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, no { - if ( p->ndims > 3 && ! p->node_kind & FOURD ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */ + if ( p->ndims > 3 && ( (! p->node_kind) & FOURD ) ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */ if ( p->node_kind & I1 ) continue ; /* short circuit anything that's not a state var */ diff --git a/tools/misc.c b/tools/misc.c index e0a00938dc..a794fd692a 100644 --- a/tools/misc.c +++ b/tools/misc.c @@ -6,6 +6,8 @@ # define index(X,Y) strchr(X,Y) #else # include +# include +# include #endif #include "protos.h" diff --git a/tools/protos.h b/tools/protos.h index 0191e8f4af..3d39c2dfa7 100644 --- a/tools/protos.h +++ b/tools/protos.h @@ -30,6 +30,9 @@ int print_warning( FILE * fp , char * fname ) ; int close_the_file( FILE * fp ) ; int make_entries_uniq ( char * fname ) ; int add_warning ( char * fname ) ; +int gen_dummy_decls ( char * dn ); +int gen_dummy_decls_new ( char * dn ); +int gen_i1_decls ( char * dn ); node_t * get_type_entry ( char * typename ) ; node_t * get_rconfig_entry( char * name ) ; @@ -157,6 +160,67 @@ void set_mask ( unsigned int * mask , int e ) ; int get_mask ( unsigned int * mask , int e ) ; int dims_ikj_inner(node_t *); int dims_ij_inner(node_t *); + +char *make_upper_case ( char * str ); +char *make_lower_case ( char * str ); +int sym_forget(); +int init_parser(); +int pre_parse( char * dir, FILE * infile, FILE * outfile ); +int check_dimspecs(); +int set_dim_order ( char * dimorder , node_t * dim_entry ); + +int gen_actual_args ( char * dirname ); +int gen_actual_args_new ( char * dirname ); +int gen_dummy_args ( char * dirname ); +int gen_dummy_args_new ( char * dirname ); +int gen_args ( char * dirname , int sw ); +int gen_args1 ( FILE * fp , char * outstr , char * structname , + node_t * node , int *linelen , int sw , int deep ); + + +int gen_namelist_defines ( char * dirname , int sw_dimension ); +int gen_namelist_defaults ( char * dirname ); +int gen_namelist_statements ( char * dirname ); +int gen_namelist_script ( char * dirname ); +int gen_get_nl_config ( char * dirname ); +int gen_config_assigns ( char * dirname ); +int gen_config_reads ( char * dirname ); + +int as_long(char *str,long *l); +int as_finite_double(char *str,double *d); +int contains_str( char *s1, char *s2 ); +int contains_tok( char *s1, char *s2, char *delims ); +int gen_nest_v_interp ( char * dirname ); +int gen_nest_interp ( char * dirname ); +int gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , int use_nest_time_level ); +int gen_nest_interp2 ( FILE * fp , node_t * node, char * fourdname, int down_path , int use_nest_time_level ); + + +int gen_streams( char * dirname ); +int gen_io_domain_defs ( FILE * fp ); +int gen_set_timekeeping_defs ( FILE *fp ); +int gen_io_form_for_dataset ( FILE *fp ); +int gen_io_form_for_stream ( FILE *fp ); +int gen_switches_and_alarms ( FILE *fp ); +int gen_check_auxstream_alarms ( FILE *fp ); +int gen_fine_stream_input ( FILE *fp ); +int gen_med_auxinput_in ( FILE *fp ); +int gen_med_hist_out_opens ( FILE *fp ); +int gen_med_hist_out_closes ( FILE *fp ); +int gen_med_auxinput_in_closes ( FILE *fp ); +int gen_med_last_solve_io ( FILE *fp ); +int gen_shutdown_closes ( FILE *fp ); +int gen_med_open_esmf_calls ( FILE *fp ); +int gen_med_find_esmf_coupling ( FILE *fp ); +int gen_io_boilerplate (); + +int gen_comms ( char * dirname ); + +int gen_set_timekeeping_alarms ( FILE * fp ); + +int create_ht(char *** p ); + + #define PROTOS_H #endif diff --git a/tools/reg_parse.c b/tools/reg_parse.c index 01176c0ea4..d7cf361dbf 100644 --- a/tools/reg_parse.c +++ b/tools/reg_parse.c @@ -6,6 +6,7 @@ # define index(X,Y) strchr(X,Y) #else # include +# include #endif #include "registry.h" @@ -116,21 +117,30 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) for ( p = inln ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; if ( !strncmp( p , "include", 7 ) && ! ( ifdef_stack_ptr >= 0 && ! ifdef_stack[ifdef_stack_ptr] ) ) { FILE *include_fp ; + char include_file_name_local_registry[128] ; char include_file_name[128] ; p += 7 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; if ( strlen( p ) > 127 ) { fprintf(stderr,"Registry warning: invalid include file name: %s\n", p ) ; } else { - sprintf( include_file_name , "%s/%s", dir , p ) ; + + sprintf( include_file_name_local_registry, "./Registry/%s", p ) ; + sprintf( include_file_name, "%s/%s", dir , p ) ; + + if ( (p=index(include_file_name_local_registry,'\n')) != NULL ) *p = '\0' ; if ( (p=index(include_file_name,'\n')) != NULL ) *p = '\0' ; + fprintf(stderr,"opening %s\n",include_file_name) ; - if (( include_fp = fopen( include_file_name , "r" )) != NULL ) { + if ( ( ( include_fp = fopen( include_file_name_local_registry, "r" ) ) != NULL ) || // Use short circuit logic here to try both sequentially + ( ( include_fp = fopen( include_file_name, "r" ) ) != NULL ) ) + { fprintf(stderr,"including %s\n",include_file_name ) ; pre_parse( dir , include_fp , outfile ) ; fclose( include_fp ) ; - } else { - fprintf(stderr,"Registry warning: cannot open %s. Ignoring.\n", include_file_name ) ; + } + else { + fprintf(stderr,"Registry warning: cannot open %s. Tried %s and %s Ignoring.\n", include_file_name, include_file_name, include_file_name_local_registry ) ; } } } @@ -255,7 +265,7 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) if ( !strcmp( tokens[F_USE] , tracers[i] ) ) found = 1 ; } if ( found == 0 ) { - sprintf(tracers[ntracers],tokens[F_USE]) ; + sprintf(tracers[ntracers],"%s",tokens[F_USE]) ; ntracers++ ; /* add entries for _b and _bt arrays */ @@ -1057,7 +1067,7 @@ check_dimspecs() p->assoc_nl_var_s,p->name ) ; return(1) ; } - if ( ! q->node_kind & RCONFIG ) + if ( (! q->node_kind) & RCONFIG ) { fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n", p->assoc_nl_var_s,p->name ) ; @@ -1082,7 +1092,7 @@ check_dimspecs() p->assoc_nl_var_e,p->name ) ; return(1) ; } - if ( ! q->node_kind & RCONFIG ) + if ( (! q->node_kind) & RCONFIG ) { fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n", p->assoc_nl_var_e,p->name ) ; diff --git a/tools/registry.c b/tools/registry.c index 79f7983ed7..b2dd0a5f6a 100644 --- a/tools/registry.c +++ b/tools/registry.c @@ -18,6 +18,9 @@ #include "data.h" #include "sym.h" +// Helper macro to actually do return checks +#define EXIT_ON_NONZERO( A ) { int result = A; if ( result != 0 ) { printf( "Error in %s, zero return expected, received %i\n", #A, result ); exit(result); } } + /* SamT: bug fix: main returns int */ int main( int argc, char *argv[], char *env[] ) @@ -132,11 +135,11 @@ main( int argc, char *argv[], char *env[] ) argv++ ; } - gen_io_boilerplate() ; /* 20091213 jm. Generate the io_boilerplate_temporary.inc file */ + EXIT_ON_NONZERO( gen_io_boilerplate() ); /* 20091213 jm. Generate the io_boilerplate_temporary.inc file */ - init_parser() ; - init_type_table() ; - init_dim_table() ; + EXIT_ON_NONZERO( init_parser() ); + EXIT_ON_NONZERO( init_type_table() ); + EXIT_ON_NONZERO( init_dim_table() ); // // possible IRR diagnostcis? // @@ -230,45 +233,45 @@ main( int argc, char *argv[], char *env[] ) } - reg_parse(fp_tmp) ; + EXIT_ON_NONZERO( reg_parse(fp_tmp) ); fclose(fp_tmp) ; - check_dimspecs() ; + check_dimspecs(); - gen_state_struct( "inc" ) ; - gen_state_subtypes( "inc" ) ; - gen_alloc( "inc" ) ; + EXIT_ON_NONZERO( gen_state_struct( "inc" ) ); + EXIT_ON_NONZERO( gen_state_subtypes( "inc" ) ); + EXIT_ON_NONZERO( gen_alloc( "inc" ) ); /* gen_alloc_count( "inc" ) ; */ - gen_dealloc( "inc" ) ; - gen_scalar_indices( "inc" ) ; - gen_module_state_description( "frame" ) ; - gen_actual_args( "inc" ) ; - gen_actual_args_new( "inc" ) ; - gen_dummy_args( "inc" ) ; - gen_dummy_args_new( "inc" ) ; - gen_dummy_decls( "inc" ) ; - gen_dummy_decls_new( "inc" ) ; - gen_i1_decls( "inc" ) ; - gen_namelist_statements("inc") ; - gen_namelist_defines ( "inc", 0 ) ; /* without dimension statements */ - gen_namelist_defines ( "inc", 1 ) ; /* with dimension statements */ - gen_namelist_defaults ( "inc" ) ; - gen_namelist_script ( "inc" ) ; - gen_get_nl_config( "inc" ) ; - gen_config_assigns( "inc" ) ; - gen_config_reads( "inc" ) ; - gen_wrf_io( "inc" ) ; - gen_model_data_ord( "inc" ) ; - gen_nest_interp( "inc" ) ; - gen_nest_v_interp( "inc") ; /*KAL added this for vertical interpolation*/ - gen_scalar_derefs( "inc" ) ; - gen_streams("inc") ; + EXIT_ON_NONZERO( gen_dealloc( "inc" ) ) ; + EXIT_ON_NONZERO( gen_scalar_indices( "inc" ) ) ; + EXIT_ON_NONZERO( gen_module_state_description( "frame" ) ) ; + EXIT_ON_NONZERO( gen_actual_args( "inc" ) ) ; + EXIT_ON_NONZERO( gen_actual_args_new( "inc" ) ) ; + EXIT_ON_NONZERO( gen_dummy_args( "inc" ) ) ; + EXIT_ON_NONZERO( gen_dummy_args_new( "inc" ) ) ; + EXIT_ON_NONZERO( gen_dummy_decls( "inc" ) ) ; + EXIT_ON_NONZERO( gen_dummy_decls_new( "inc" ) ) ; + EXIT_ON_NONZERO( gen_i1_decls( "inc" ) ) ; + EXIT_ON_NONZERO( gen_namelist_statements("inc") ; ) + EXIT_ON_NONZERO( gen_namelist_defines ( "inc", 0 ) ) ; /* without dimension statements */ + EXIT_ON_NONZERO( gen_namelist_defines ( "inc", 1 ) ) ; /* with dimension statements */ + EXIT_ON_NONZERO( gen_namelist_defaults ( "inc" ) ) ; + EXIT_ON_NONZERO( gen_namelist_script ( "inc" ) ) ; + EXIT_ON_NONZERO( gen_get_nl_config( "inc" ) ) ; + EXIT_ON_NONZERO( gen_config_assigns( "inc" ) ) ; + EXIT_ON_NONZERO( gen_config_reads( "inc" ) ) ; + EXIT_ON_NONZERO( gen_wrf_io( "inc" ) ) ; + EXIT_ON_NONZERO( gen_model_data_ord( "inc" ) ) ; + EXIT_ON_NONZERO( gen_nest_interp( "inc" ) ) ; + EXIT_ON_NONZERO( gen_nest_v_interp( "inc") ; ) /*KAL added this for vertical interpolation*/ + EXIT_ON_NONZERO( gen_scalar_derefs( "inc" ) ) ; + EXIT_ON_NONZERO( gen_streams("inc") ; ) /* this has to happen after gen_nest_interp, which adds halos to the AST */ - gen_comms( "inc" ) ; /* this is either package supplied (by copying a */ - /* gen_comms.c file into this directory) or a */ - /* stubs routine. */ + EXIT_ON_NONZERO( gen_comms( "inc" ) ); /* this is either package supplied (by copying a */ + /* gen_comms.c file into this directory) or a */ + /* stubs routine. */ cleanup: #ifdef _WIN32 diff --git a/tools/sym.c b/tools/sym.c index de41c2d965..d6977116f5 100644 --- a/tools/sym.c +++ b/tools/sym.c @@ -61,12 +61,43 @@ */ #include +#include +#include "protos.h" #include "sym.h" -extern sym_nodeptr symget() ; +extern sym_nodeptr symget(char *name, sym_nodeptr (*newnode)(), char **(*nodename)(sym_nodeptr), sym_nodeptr *(*nodenext)(sym_nodeptr), char ** symtab, int flag); static char ** symtab ; /* 2-19-90 */ + +sym_nodeptr +new_sym_node() +{ + sym_nodeptr p ; + p = (sym_nodeptr) malloc( sizeof( struct sym_node ) ) ; + p->name = NULL ; + p->next = NULL ; + + return( p ) ; +} + +char ** +node_name(sym_nodeptr p) +{ + char ** x ; + x = &(p->name) ; + return( x ) ; +} + +sym_nodeptr * +node_next(sym_nodeptr p) +{ + sym_nodeptr *x ; + x = &(p->next) ; + return( x ) ; +} + + int sym_init() /* 2-19-90, initialize symbol table package */ { @@ -80,58 +111,29 @@ sym_init() /* 2-19-90, initialize symbol table package */ } sym_nodeptr -sym_add( name ) -char * name ; +sym_add( char * name ) { +/* sym_nodeptr new_sym_node(); char **node_name() ; sym_nodeptr *node_next() ; +*/ return( symget( name, new_sym_node, node_name, node_next, symtab, 1 ) ) ; } sym_nodeptr -sym_get( name ) -char * name ; +sym_get( char * name ) { +/* sym_nodeptr new_sym_node(); char **node_name() ; sym_nodeptr *node_next() ; +*/ return( symget( name, new_sym_node, node_name, node_next, symtab, 0 ) ) ; } -sym_nodeptr -new_sym_node() -{ - void * malloc() ; - sym_nodeptr p ; - p = (sym_nodeptr) malloc( sizeof( struct sym_node ) ) ; - p->name = NULL ; - p->next = NULL ; - - return( p ) ; -} - -char ** -node_name(p) -sym_nodeptr p ; -{ - char ** x ; - x = &(p->name) ; - return( x ) ; -} - -sym_nodeptr * -node_next(p) -sym_nodeptr p ; -{ - sym_nodeptr *x ; - x = &(p->next) ; - return( x ) ; -} - int -show_entry(x) -sym_nodeptr x ; +show_entry(sym_nodeptr x) { int i ; if ( x == NULL ) return(0) ; diff --git a/tools/sym.h b/tools/sym.h index 9431f5d2b8..5480b9d908 100644 --- a/tools/sym.h +++ b/tools/sym.h @@ -89,7 +89,7 @@ struct sym_node int marked ; /* general purpose marker */ } ; -sym_nodeptr sym_add() ; -sym_nodeptr sym_get() ; +sym_nodeptr sym_add(char *) ; +sym_nodeptr sym_get(char *); #endif diff --git a/tools/symtab_gen.c b/tools/symtab_gen.c index 47870f6c88..a6ddcf9661 100644 --- a/tools/symtab_gen.c +++ b/tools/symtab_gen.c @@ -32,25 +32,24 @@ For a sample main or calling program see the end of this file. */ #include +#include #include #ifndef _WIN32 # include #endif +#include "protos.h" #define HASHSIZE 1024 /* commented out 2-29-90 static char * symtab[HASHSIZE] ; */ - +/* void * malloc() ; void * calloc() ; +*/ -char * symget(name,newnode,nodename,nodenext,symtab,flag) -char *name ; -char *(*newnode)(), **(*nodename)(), **(*nodenext)() ; -char *symtab[] ; -int flag ; /* 1 is create if not there, 0 return NULL if not there */ +char * symget(char *name,char *(*newnode)(),char **(*nodename)(char *),char **(*nodenext)(char *), char *symtab[], int flag) /* flag = 1 is create if not there, 0 return NULL if not there */ { int index ; int found ; @@ -94,9 +93,7 @@ int flag ; /* 1 is create if not there, 0 return NULL if not there */ return(p) ; } -int -hash(name) -char * name ; +int hash(char * name ) { register int result = 0 ; register char * p = name ; @@ -113,9 +110,7 @@ char * name ; /* added 2-19-90, attaches a new hash table to pointer */ -int -create_ht( p ) -char *** p ; +int create_ht(char *** p ) { *p = (char **) calloc( HASHSIZE , sizeof( char * ) ) ; return(0) ; @@ -130,11 +125,7 @@ function to each entry */ -int -sym_traverse( ht, nodenext, f ) -char *ht[] ; -char **(*nodenext)() ; -void (*f)() ; +int sym_traverse( char *ht[] , char **(*nodenext)(char *), void (*f)(char *) ) { char * p, **x ; int i ; @@ -173,25 +164,20 @@ struct symnode { extern struct symnode * symget() ; -struct symnode * -newnode() +struct symnode * newnode() { struct symnode * malloc() ; return( malloc( sizeof( struct symnode ) ) ) ; } -char ** -nodename(p) -struct symnode *p ; +char ** nodename(struct symnode *p) { char ** x ; x = &(p->name) ; return( x ) ; } -struct symnode ** -nodenext(p) -struct symnode *p ; +struct symnode ** nodenext(struct symnode *p) { struct symnode **x ; x = &(p->next) ; diff --git a/var/build/da.make b/var/build/da.make index 0ee2c483df..6770f48734 100644 --- a/var/build/da.make +++ b/var/build/da.make @@ -29,6 +29,7 @@ WRFVAR_OBJS = \ da_pilot.o \ da_radar.o \ da_rain.o \ + da_lightning.o \ da_gpspw.o \ da_gpsref.o \ da_gpseph.o \ diff --git a/var/build/depend.txt b/var/build/depend.txt index 8b90b55d4b..3d12fee59c 100644 --- a/var/build/depend.txt +++ b/var/build/depend.txt @@ -111,7 +111,7 @@ da_bogus.o : da_bogus.f90 da_calculate_grady_bogus.inc da_get_innov_vector_bogus da_buoy.o : da_buoy.f90 da_calculate_grady_buoy.inc da_get_innov_vector_buoy.inc da_check_max_iv_buoy.inc da_transform_xtoy_buoy_adj.inc da_transform_xtoy_buoy.inc da_print_stats_buoy.inc da_oi_stats_buoy.inc da_residual_buoy.inc da_jo_and_grady_buoy.inc da_ao_stats_buoy.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_control.o : da_control.f90 module_driver_constants.o da_crtm.o : da_crtm.f90 da_det_crtm_climat.inc da_crtm_sensor_descriptor.inc da_crtm_init.inc da_crtm_ad.inc da_crtm_direct.inc da_crtm_k.inc da_crtm_tl.inc da_get_innov_vector_crtm.inc da_transform_xtoy_crtm_adj.inc da_transform_xtoy_crtm.inc da_tracing.o da_tools.o da_tools_serial.o da_reporting.o da_radiance1.o module_dm.o da_physics.o da_interpolation.o da_control.o module_radiance.o da_define_structures.o module_domain.o -da_define_structures.o : da_define_structures.f90 da_gauss_noise.inc da_random_seed.inc da_initialize_cv.inc da_zero_vp_type.inc da_zero_y.inc da_zero_x.inc da_deallocate_y.inc da_deallocate_observations.inc da_deallocate_background_errors.inc da_allocate_y.inc da_allocate_observations.inc da_allocate_background_errors.inc da_wavelet.o da_reporting.o da_tools_serial.o da_tracing.o da_control.o module_domain.o da_allocate_y_rain.inc da_allocate_y_radar.inc da_allocate_observations_rain.inc da_allocate_obs_info.inc da_zero_xchem_type.inc module_state_description.o da_allocate_observations_chem_sfc.inc +da_define_structures.o : da_define_structures.f90 da_gauss_noise.inc da_random_seed.inc da_initialize_cv.inc da_zero_vp_type.inc da_zero_y.inc da_zero_x.inc da_deallocate_y.inc da_deallocate_observations.inc da_deallocate_background_errors.inc da_allocate_y.inc da_allocate_observations.inc da_allocate_background_errors.inc da_wavelet.o da_reporting.o da_tools_serial.o da_tracing.o da_control.o module_domain.o da_allocate_y_rain.inc da_allocate_y_lightning.inc da_allocate_y_radar.inc da_allocate_observations_rain.inc da_allocate_obs_info.inc da_zero_xchem_type.inc module_state_description.o da_allocate_observations_chem_sfc.inc da_dynamics.o : da_dynamics.f90 da_wz_base.inc da_uv_to_vorticity.inc da_w_adjustment_adj.inc da_w_adjustment_lin.inc da_uv_to_divergence_adj.inc da_uv_to_divergence.inc da_psichi_to_uv_adj.inc da_psichi_to_uv.inc da_hydrostaticp_to_rho_lin.inc da_hydrostaticp_to_rho_adj.inc da_balance_geoterm_lin.inc da_balance_geoterm_adj.inc da_balance_equation_lin.inc da_balance_equation_adj.inc da_balance_cycloterm_lin.inc da_balance_cycloterm_adj.inc da_balance_cycloterm.inc da_wpec_constraint.inc da_wpec_constraint_adj.inc da_wpec_constraint_cycloterm.inc da_wpec_constraint_geoterm.inc da_wpec_constraint_lin.inc da_tools.o da_tracing.o da_ffts.o da_reporting.o da_define_structures.o module_comm_dm.o module_dm.o module_domain.o da_control.o da_divergence_constraint.inc da_divergence_constraint_adj.inc da_etkf.o : da_etkf.f90 da_solve_etkf.inc da_matmultiover.inc da_matmulti.inc da_innerprod.inc da_lapack.o da_gen_be.o da_control.o da_ffts.o : da_ffts.f90 da_solve_poissoneqn_fst_adj.inc da_solve_poissoneqn_fst.inc da_solve_poissoneqn_fct_adj.inc da_solve_poissoneqn_fct.inc module_ffts.o module_comm_dm.o module_dm.o da_wrf_interfaces.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o @@ -125,36 +125,37 @@ da_interpolation.o : da_interpolation.f90 da_interp_msk_avg_2d_partial.inc da_in da_lapack.o : da_lapack.f90 dlamch.inc dlarf.inc dlarfg.inc dlarft.inc dlarfb.inc dorg2l.inc dorg2r.inc dsytd2.inc dlatrd.inc dorgqr.inc dorgql.inc dlassq.inc dlapy2.inc dlartg.inc dlasrt.inc dlansy.inc dsytrd.inc dsterf.inc dorgtr.inc dlae2.inc dlasr.inc dlaev2.inc dlascl.inc dlanst.inc dlaset.inc iparmq.inc ieeeck.inc ilaenv.inc dsteqr.inc dsyev.inc da_blas.o da_mat_cv3.o : da_mat_cv3.f90 da_metar.o : da_metar.f90 da_calculate_grady_metar.inc da_get_innov_vector_metar.inc da_check_max_iv_metar.inc da_transform_xtoy_metar_adj.inc da_transform_xtoy_metar.inc da_print_stats_metar.inc da_oi_stats_metar.inc da_residual_metar.inc da_jo_and_grady_metar.inc da_ao_stats_metar.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o -da_minimisation.o : da_minimisation.f90 da_read_basicstates.inc da_swap_xtraj.inc da_lanczos_io.inc da_kmat_mul.inc da_amat_mul.inc da_sensitivity.inc da_adjoint_sensitivity.inc da_transform_vtoy_adj.inc da_transform_vtoy.inc da_calculate_grady.inc da_minimise_lz.inc da_minimise_cg.inc da_write_diagnostics.inc da_dot_cv.inc da_dot.inc da_get_innov_vector.inc da_get_var_diagnostics.inc da_calculate_residual.inc da_jo_and_grady.inc da_calculate_gradj.inc da_calculate_j.inc da_transform_vtod_wpec.inc da_transform_vtod_wpec_adj.inc module_io_wrf.o da_4dvar.o da_lapack.o module_symbols_util.o da_wrf_interfaces.o da_vtox_transforms.o da_varbc.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_synop.o da_ssmi.o da_sound.o da_ships.o da_satem.o da_reporting.o da_rain.o da_radar.o da_radiance1.o da_radiance.o da_tamdar.o da_mtgirs.o da_qscat.o da_pseudo.o da_profiler.o da_polaramv.o da_par_util1.o da_par_util.o da_pilot.o da_metar.o da_obs_io.o da_gpsref.o da_gpspw.o da_geoamv.o da_obs.o da_define_structures.o da_control.o da_buoy.o da_bogus.o da_airsr.o da_airep.o module_state_description.o module_domain.o module_dm.o module_configure.o da_join_iv_for_multi_inc.o da_wrfvar_io.o da_gpseph.o da_varbc_tamdar.o da_chem_sfc.o +da_minimisation.o : da_minimisation.f90 da_read_basicstates.inc da_swap_xtraj.inc da_lanczos_io.inc da_kmat_mul.inc da_amat_mul.inc da_sensitivity.inc da_adjoint_sensitivity.inc da_transform_vtoy_adj.inc da_transform_vtoy.inc da_calculate_grady.inc da_minimise_lz.inc da_minimise_cg.inc da_write_diagnostics.inc da_dot_cv.inc da_dot.inc da_get_innov_vector.inc da_get_var_diagnostics.inc da_calculate_residual.inc da_jo_and_grady.inc da_calculate_gradj.inc da_calculate_j.inc da_transform_vtod_wpec.inc da_transform_vtod_wpec_adj.inc module_io_wrf.o da_4dvar.o da_lapack.o module_symbols_util.o da_wrf_interfaces.o da_vtox_transforms.o da_varbc.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_synop.o da_ssmi.o da_sound.o da_ships.o da_satem.o da_reporting.o da_rain.o da_radar.o da_lightning.o da_radiance1.o da_radiance.o da_tamdar.o da_mtgirs.o da_qscat.o da_pseudo.o da_profiler.o da_polaramv.o da_par_util1.o da_par_util.o da_pilot.o da_metar.o da_obs_io.o da_gpsref.o da_gpspw.o da_geoamv.o da_obs.o da_define_structures.o da_control.o da_buoy.o da_bogus.o da_airsr.o da_airep.o module_state_description.o module_domain.o module_dm.o module_configure.o da_join_iv_for_multi_inc.o da_wrfvar_io.o da_gpseph.o da_varbc_tamdar.o da_chem_sfc.o da_module_convert_tool.o : da_module_convert_tool.f90 da_convertor_v_interp.inc da_module_couple_uv.o : da_module_couple_uv.f90 da_couple.inc da_calc_mu_uv.inc da_couple_uv.inc da_module_couple_uv_ad.o : da_module_couple_uv_ad.f90 da_couple_ad.inc da_calc_mu_uv_ad.inc da_couple_uv_ad.inc da_module_couple_uv.o da_mtgirs.o : da_mtgirs.f90 da_calculate_grady_mtgirs.inc da_get_innov_vector_mtgirs.inc da_check_max_iv_mtgirs.inc da_transform_xtoy_mtgirs_adj.inc da_transform_xtoy_mtgirs.inc da_print_stats_mtgirs.inc da_oi_stats_mtgirs.inc da_residual_mtgirs.inc da_jo_mtgirs_uvtq.inc da_jo_and_grady_mtgirs.inc da_ao_stats_mtgirs.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_netcdf_interface.o : da_netcdf_interface.f90 da_atotime.inc da_get_bdytimestr_cdf.inc da_get_bdyfrq.inc da_put_att_cdf.inc da_get_att_cdf.inc da_put_var_2d_int_cdf.inc da_get_var_2d_int_cdf.inc da_put_var_2d_real_cdf.inc da_put_var_3d_real_cdf.inc da_get_var_2d_real_cdf.inc da_get_var_3d_real_cdf.inc da_get_gl_att_real_cdf.inc da_get_gl_att_int_cdf.inc da_get_dims_cdf.inc da_get_times_cdf.inc da_get_var_1d_real_cdf.inc -da_obs.o : da_obs.f90 da_grid_definitions.o da_set_obs_missing.inc da_obs_sensitivity.inc da_count_filtered_obs.inc da_store_obs_grid_info_rad.inc da_store_obs_grid_info.inc da_random_omb_all.inc da_fill_obs_structures.inc da_fill_obs_structures_rain.inc da_fill_obs_structures_radar.inc da_check_missing.inc da_add_noise_to_ob.inc da_transform_xtoy_adj.inc da_transform_xtoy.inc da_obs_proc_station.inc module_dm.o da_tracing.o da_tools.o da_tools_serial.o da_synop.o da_ssmi.o da_tamdar.o da_mtgirs.o da_sound.o da_ships.o da_satem.o da_rttov.o da_reporting.o da_rain.o da_radar.o da_qscat.o da_pseudo.o da_profiler.o da_polaramv.o da_pilot.o da_physics.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_crtm.o da_control.o da_buoy.o da_bogus.o da_airsr.o da_airep.o module_domain.o da_define_structures.o da_gpseph.o module_state_description.o da_fill_obs_structures_chem_sfc.inc da_chem_sfc.o +da_obs.o : da_obs.f90 da_grid_definitions.o da_set_obs_missing.inc da_obs_sensitivity.inc da_count_filtered_obs.inc da_store_obs_grid_info_rad.inc da_store_obs_grid_info.inc da_random_omb_all.inc da_fill_obs_structures.inc da_fill_obs_structures_rain.inc da_fill_obs_structures_radar.inc da_fill_obs_structures_lightning.inc da_check_missing.inc da_add_noise_to_ob.inc da_transform_xtoy_adj.inc da_transform_xtoy.inc da_obs_proc_station.inc module_dm.o da_tracing.o da_tools.o da_tools_serial.o da_synop.o da_ssmi.o da_tamdar.o da_mtgirs.o da_sound.o da_ships.o da_satem.o da_rttov.o da_reporting.o da_rain.o da_radar.o da_lightning.o da_qscat.o da_pseudo.o da_profiler.o da_polaramv.o da_pilot.o da_physics.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_crtm.o da_control.o da_buoy.o da_bogus.o da_airsr.o da_airep.o module_domain.o da_define_structures.o da_gpseph.o module_state_description.o da_fill_obs_structures_chem_sfc.inc da_chem_sfc.o da_chem_sfc.o: da_chem_sfc.f90 da_jo_and_grady_chem_sfc.inc da_jo_chem_sfc.inc da_residual_chem_sfc.inc da_transform_xtoy_chem_sfc.inc da_transform_xtoy_chem_sfc_adj.inc da_get_innov_vector_chem_sfc.inc da_check_max_iv_chem_sfc.inc da_calculate_grady_chem_sfc.inc da_interpolation.o module_dm.o module_domain.o da_control.o da_reporting.o da_tools_serial.o da_tools.o da_define_structures.o da_obs.o da_define_structures.o da_ao_stats_chem_sfc.inc da_oi_stats_chem_sfc.inc da_print_stats_chem_sfc.inc -da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc da_read_obs_chem_sfc.inc da_scan_obs_chem_sfc.inc da_write_obs_chem_sfc.inc da_final_write_obs_chem_sfc.inc da_final_write_obs_gas_sfc.inc da_read_obs_bufr_satwnd.inc +da_obs_io.o : da_obs_io.f90 da_grid_definitions.o da_final_write_modified_filtered_obs.inc da_final_write_filtered_obs.inc da_write_noise_to_ob.inc da_read_omb_tmp.inc da_read_rand_unit.inc da_read_y_unit.inc da_final_write_y.inc da_final_write_obs.inc da_read_obs_bufrgpsro.inc da_read_obs_bufr.inc da_write_y.inc da_write_modified_filtered_obs.inc da_write_filtered_obs.inc da_write_obs_etkf.inc da_search_obs.inc da_read_iv_for_multi_inc.inc da_write_iv_for_multi_inc.inc da_write_obs.inc da_use_obs_errfac.inc da_read_errfac.inc da_read_obs_rain.inc da_scan_obs_rain.inc da_scan_obs_radar.inc da_read_obs_radar.inc da_scan_obs_lightning.inc da_read_obs_lightning.inc da_scan_obs_ascii.inc da_read_obs_ascii.inc da_par_util.o gsi_thinning.o module_radiance.o da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_physics.o da_par_util1.o da_obs.o da_grid_definitions.o da_define_structures.o da_control.o module_domain.o da_read_lsac_util.inc da_read_obs_lsac.inc da_scan_obs_lsac.inc da_netcdf_interface.o da_gpseph.o da_read_obs_bufrgpsro_eph.inc da_read_obs_chem_sfc.inc da_scan_obs_chem_sfc.inc da_write_obs_chem_sfc.inc da_final_write_obs_chem_sfc.inc da_final_write_obs_gas_sfc.inc da_read_obs_bufr_satwnd.inc da_par_util.o : da_par_util.f90 da_proc_maxmin_combine.inc da_proc_stats_combine.inc da_system.inc da_y_facade_to_global.inc da_generic_boilerplate.inc da_deallocate_global_synop.inc da_deallocate_global_sound.inc da_deallocate_global_sonde_sfc.inc da_generic_methods.inc da_patch_to_global_3d.inc da_patch_to_global_dual_res.inc da_patch_to_global_2d.inc da_cv_to_global.inc da_transpose_y2x_v2.inc da_transpose_x2y_v2.inc da_transpose_z2y.inc da_transpose_y2z.inc da_transpose_x2z.inc da_transpose_z2x.inc da_transpose_y2x.inc da_transpose_x2y.inc da_unpack_count_obs.inc da_pack_count_obs.inc da_copy_tile_dims.inc da_copy_dims.inc da_alloc_and_copy_be_arrays.inc da_vv_to_cv.inc da_cv_to_vv.inc da_generic_typedefs.inc da_wrf_interfaces.o da_tracing.o da_reporting.o da_define_structures.o da_par_util1.o module_dm.o module_domain.o da_control.o da_par_util1.o : da_par_util1.f90 da_proc_sum_real.inc da_proc_sum_ints.inc da_proc_sum_int.inc da_control.o module_state_description.o -da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o +da_physics.o : da_physics.f90 da_uv_to_sd_lin.inc da_uv_to_sd_adj.inc da_integrat_dz.inc da_wdt.inc da_filter_adj.inc da_filter.inc da_evapo_lin.inc da_condens_lin.inc da_condens_adj.inc da_moist_phys_lin.inc da_moist_phys_adj.inc da_sfc_pre_adj.inc da_sfc_pre_lin.inc da_sfc_pre.inc da_transform_xtowtq_adj.inc da_transform_xtowtq.inc da_transform_xtopsfc_adj.inc da_transform_xtopsfc.inc da_sfc_wtq_adj.inc da_sfc_wtq_lin.inc da_sfc_wtq.inc da_julian_day.inc da_roughness_from_lanu.inc da_get_q_error.inc da_check_rh_simple.inc da_check_rh.inc da_transform_xtogpsref_lin.inc da_transform_xtogpsref_adj.inc da_transform_xtogpsref.inc da_transform_xtotpw_adj.inc da_transform_xtotpw.inc da_transform_xtoztd_adj.inc da_transform_xtoztd_lin.inc da_transform_xtoztd.inc da_tv_profile_tl.inc da_thickness_tl.inc da_find_layer_adj.inc da_thickness.inc da_tv_profile_adj.inc da_find_layer.inc da_thickness_adj.inc da_find_layer_tl.inc da_tv_profile.inc da_tpq_to_slp_adj.inc da_tpq_to_slp_lin.inc da_wrf_tpq_2_slp.inc da_tpq_to_slp.inc da_trh_to_td.inc da_tp_to_qs_lin1.inc da_tp_to_qs_lin.inc da_tp_to_qs_adj1.inc da_tp_to_qs_adj.inc da_tp_to_qs1.inc da_tp_to_qs.inc da_tprh_to_q_lin1.inc da_tprh_to_q_lin.inc da_tprh_to_q_adj1.inc da_tprh_to_q_adj.inc da_tpq_to_rh_lin1.inc da_tpq_to_rh_lin.inc da_tpq_to_rh.inc da_pt_to_rho_lin.inc da_pt_to_rho_adj.inc da_uvprho_to_w_adj.inc da_uvprho_to_w_lin.inc da_prho_to_t_lin.inc da_prho_to_t_adj.inc da_trop_wmo.inc da_wrf_interfaces.o da_reporting.o da_dynamics.o da_interpolation.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_grid_definitions.o da_gpseph.o da_pilot.o : da_pilot.f90 da_calculate_grady_pilot.inc da_get_innov_vector_pilot.inc da_check_max_iv_pilot.inc da_transform_xtoy_pilot_adj.inc da_transform_xtoy_pilot.inc da_print_stats_pilot.inc da_oi_stats_pilot.inc da_residual_pilot.inc da_jo_and_grady_pilot.inc da_ao_stats_pilot.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_polaramv.o : da_polaramv.f90 da_calculate_grady_polaramv.inc da_get_innov_vector_polaramv.inc da_check_max_iv_polaramv.inc da_transform_xtoy_polaramv_adj.inc da_transform_xtoy_polaramv.inc da_print_stats_polaramv.inc da_oi_stats_polaramv.inc da_residual_polaramv.inc da_jo_and_grady_polaramv.inc da_ao_stats_polaramv.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_profiler.o : da_profiler.f90 da_calculate_grady_profiler.inc da_get_innov_vector_profiler.inc da_check_max_iv_profiler.inc da_transform_xtoy_profiler_adj.inc da_transform_xtoy_profiler.inc da_print_stats_profiler.inc da_oi_stats_profiler.inc da_residual_profiler.inc da_jo_and_grady_profiler.inc da_ao_stats_profiler.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_pseudo.o : da_pseudo.f90 da_calculate_grady_pseudo.inc da_transform_xtoy_pseudo_adj.inc da_transform_xtoy_pseudo.inc da_print_stats_pseudo.inc da_oi_stats_pseudo.inc da_ao_stats_pseudo.inc da_get_innov_vector_pseudo.inc da_residual_pseudo.inc da_jo_and_grady_pseudo.inc da_tracing.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_qscat.o : da_qscat.f90 da_calculate_grady_qscat.inc da_transform_xtoy_qscat_adj.inc da_transform_xtoy_qscat.inc da_print_stats_qscat.inc da_oi_stats_qscat.inc da_ao_stats_qscat.inc da_get_innov_vector_qscat.inc da_check_max_iv_qscat.inc da_residual_qscat.inc da_jo_and_grady_qscat.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o -da_rad_diags.o : da_rad_diags.f90 +da_rad_diags.o : da_rad_diags.f90 da_radar.o : da_radar.f90 da_write_oa_radar_ascii.inc da_max_error_qc_radar.inc da_calculate_grady_radar.inc da_radial_velocity_adj.inc da_radial_velocity_lin.inc da_radial_velocity.inc da_radar_rf.inc da_get_innov_vector_radar.inc da_check_max_iv_radar.inc da_transform_xtoy_radar_adj.inc da_transform_xtoy_radar.inc da_print_stats_radar.inc da_oi_stats_radar.inc da_residual_radar.inc da_jo_and_grady_radar.inc da_ao_stats_radar.inc da_tools_serial.o da_reporting.o da_tracing.o da_tools.o da_statistics.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_radzicevar_calc_ice_abc.inc da_radzicevar_pkx.inc da_radzicevar_rain_adj.inc da_radzicevar_virtual.inc da_radzicevar_cal_tl_fw4wetice.inc da_radzicevar_parameter_zrx.inc da_radzicevar_prepare_interceptpara.inc da_radzicevar_rain_tl.inc da_radzicevar_waterfraction.inc da_radzicevar_dryice_adj.inc da_radzicevar_parameter_zxx.inc da_radzicevar_prepare_mixingratios.inc da_radzicevar_rhoair_tl.inc da_radzicevar_wetice_adj.inc da_radzicevar_dryice_tl.inc da_radzicevar_prepare_zmm_adj.inc da_radzicevar_sigma_in_abc.inc da_radzicevar_wetice_tl.inc da_radzicevar_pxabk.inc da_radzicevar_upper_f.inc da_radzicevar.inc da_radzicevar_tl.inc da_radzicevar_adj.inc -da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_satzen.inc da_read_obs_hdf5ahi.inc da_read_obs_netcdf4ahi_jaxa.inc da_read_obs_hdf5gmi.inc da_read_obs_netcdf4ahi_geocat.inc mod_clddet_geoir.o -da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_wrf_interfaces.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc da_qc_gmi.inc +da_radiance.o : da_radiance.f90 da_blacklist_rad.inc da_read_pseudo_rad.inc da_get_innov_vector_radiance.inc da_radiance_init.inc da_setup_radiance_structures.inc da_sort_rad.inc da_read_kma1dvar.inc da_initialize_rad_iv.inc da_allocate_rad_iv.inc da_read_obs_bufrssmis.inc da_read_obs_bufrairs.inc da_read_obs_bufriasi.inc da_read_obs_bufrseviri.inc da_read_obs_bufrtovs.inc da_write_filtered_rad.inc da_read_simulated_rad.inc da_read_filtered_rad.inc da_calculate_grady_rad.inc gsi_thinning.o da_wrf_interfaces.o da_varbc.o da_tracing.o da_tools.o da_statistics.o da_rttov.o da_reporting.o da_radiance1.o da_physics.o da_par_util.o da_par_util1.o da_tools_serial.o da_interpolation.o da_define_structures.o da_crtm.o da_control.o module_radiance.o module_domain.o module_dm.o amsr2time_.c da_read_obs_hdf5amsr2.inc da_deallocate_radiance.inc da_read_obs_ncgoesimg.inc da_get_sat_angles.inc da_get_sat_angles_1d.inc da_get_solar_angles.inc da_get_solar_angles_1d.inc da_get_satzen.inc da_read_obs_hdf5ahi.inc da_read_obs_netcdf4ahi_jaxa.inc da_read_obs_hdf5gmi.inc da_read_obs_netcdf4ahi_geocat.inc mod_clddet_geoir.o da_read_obs_ncgoesabi.inc +da_radiance1.o : da_radiance1.f90 da_mspps_ts.inc da_mspps_emis.inc da_setup_satcv.inc da_qc_rad.inc da_print_stats_rad.inc da_oi_stats_rad.inc da_ao_stats_rad.inc da_cld_eff_radius.inc da_detsurtyp.inc da_write_oa_rad_ascii.inc da_write_iv_rad_ascii.inc da_qc_mhs.inc da_qc_ssmis.inc da_qc_hirs.inc da_qc_amsub.inc da_qc_amsua.inc da_qc_airs.inc da_cloud_detect.inc da_cloud_sim.inc da_qc_seviri.inc da_qc_iasi.inc da_qc_crtm.inc da_predictor_crtm.inc da_predictor_rttov.inc da_write_biasprep.inc da_biasprep.inc da_read_biascoef.inc da_biascorr.inc da_residual_rad.inc da_jo_and_grady_rad.inc gsi_constants.o da_tracing.o da_tools_serial.o da_tools.o da_statistics.o da_reporting.o da_par_util1.o da_par_util.o module_dm.o da_define_structures.o da_control.o module_radiance.o da_wrf_interfaces.o da_qc_amsr2.inc da_qc_goesimg.inc da_qc_ahi.inc da_qc_gmi.inc da_qc_goesabi.inc +da_lightning.o : da_lightning.f90 da_calculate_grady_lightning.inc da_get_innov_vector_lightning.inc da_check_max_iv_lightning.inc da_transform_xtoy_lightning_adj.inc da_transform_xtoy_lightning.inc da_print_stats_lightning.inc da_oi_stats_lightning.inc da_residual_lightning.inc da_jo_and_grady_lightning.inc da_ao_stats_lightning.inc da_div_profile.inc da_div_profile_adj.inc da_div_profile_tl.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_rain.o : da_rain.f90 da_calculate_grady_rain.inc da_get_innov_vector_rain.inc da_get_hr_rain.inc da_check_max_iv_rain.inc da_transform_xtoy_rain_adj.inc da_transform_xtoy_rain.inc da_print_stats_rain.inc da_oi_stats_rain.inc da_residual_rain.inc da_jo_and_grady_rain.inc da_ao_stats_rain.inc da_tracing.o da_tools.o da_statistics.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_domain.o da_recursive_filter.o : da_recursive_filter.f90 da_apply_rf_adj.inc da_apply_rf.inc da_apply_rf_1v_adj.inc da_apply_rf_1v.inc da_transform_through_rf_adj.inc da_transform_through_rf.inc da_transform_through_rf_inv.inc da_recursive_filter_1d_adj.inc da_recursive_filter_1d.inc da_recursive_filter_1d_inv.inc da_calculate_rf_factors.inc da_transform_through_rf_dual_res.inc da_transform_through_rf_adj_dual_res.inc da_perform_2drf.inc da_rf_cv3.o da_rfz_cv3.o da_tracing.o da_par_util.o da_define_structures.o da_control.o module_domain.o da_reporting.o : da_reporting.f90 da_message2.inc da_message.inc da_warning.inc da_error.inc da_control.o da_rf_cv3.o : da_rf_cv3.f90 da_mat_cv3.o da_rfz_cv3.o : da_rfz_cv3.f90 da_rsl_interfaces.o : da_rsl_interfaces.f90 -da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o +da_rttov.o : da_rttov.f90 da_rttov_ad.inc da_rttov_tl.inc da_rttov_direct.inc da_rttov_init.inc da_transform_xtoy_rttov_adj.inc da_transform_xtoy_rttov.inc da_get_innov_vector_rttov.inc da_rttov_k.inc da_wrf_interfaces.o da_tracing.o da_tools.o da_radiance1.o da_par_util.o da_tools_serial.o da_interpolation.o da_control.o module_radiance.o da_reporting.o module_domain.o da_define_structures.o da_physics.o da_satem.o : da_satem.f90 da_calculate_grady_satem.inc da_get_innov_vector_satem.inc da_check_max_iv_satem.inc da_transform_xtoy_satem_adj.inc da_transform_xtoy_satem.inc da_print_stats_satem.inc da_oi_stats_satem.inc da_residual_satem.inc da_jo_and_grady_satem.inc da_ao_stats_satem.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_par_util1.o da_par_util.o da_define_structures.o da_control.o module_domain.o -da_setup_structures.o : da_setup_structures.f90 da_truncate_spectra.inc da_get_bins_info.inc da_write_kma_increments.inc da_write_increments_for_wrf_nmm_regional.inc da_write_increments.inc da_qfrmrh.inc da_cumulus.inc da_lcl.inc da_cloud_model.inc da_setup_runconstants.inc da_setup_obs_interp_wts.inc da_setup_obs_structures_madis.inc da_setup_obs_structures_bufr.inc da_setup_obs_structures_ascii.inc da_setup_obs_structures_rain.inc da_setup_obs_structures_radar.inc da_setup_obs_structures.inc da_setup_flow_predictors.inc da_setup_flow_predictors_para_read_opt1.inc da_chgvres.inc da_setup_cv.inc da_setup_be_nmm_regional.inc da_setup_be_regional.inc da_setup_be_ncep_gfs.inc da_setup_be_global.inc da_setup_background_errors.inc da_scale_background_errors.inc da_scale_background_errors_cv3.inc da_rescale_background_errors.inc da_interpolate_regcoeff.inc da_get_vertical_truncation.inc gsi_thinning.o module_radiance.o da_rf_cv3.o da_rfz_cv3.o da_vtox_transforms.o da_tracing.o da_tools.o da_tools_serial.o da_ssmi.o da_spectral.o da_recursive_filter.o da_reporting.o da_radiance.o da_par_util.o da_par_util1.o da_obs_io.o da_obs.o da_control.o da_wrf_interfaces.o da_define_structures.o module_domain.o da_wavelet.o da_chg_be_Vres.inc da_gen_eigen.inc da_eigen_to_covmatrix.inc da_setup_pseudo_obs.inc da_setup_flow_predictors_ep_format2.inc da_setup_flow_predictors_ep_format3.inc da_get_alpha_vertloc.inc da_write_vp.inc module_state_description.o da_setup_obs_structures_chem_sfc.inc +da_setup_structures.o : da_setup_structures.f90 da_truncate_spectra.inc da_get_bins_info.inc da_write_kma_increments.inc da_write_increments_for_wrf_nmm_regional.inc da_write_increments.inc da_qfrmrh.inc da_cumulus.inc da_lcl.inc da_cloud_model.inc da_setup_runconstants.inc da_setup_obs_interp_wts.inc da_setup_obs_structures_madis.inc da_setup_obs_structures_bufr.inc da_setup_obs_structures_ascii.inc da_setup_obs_structures_rain.inc da_setup_obs_structures_radar.inc da_setup_obs_structures_lightning.inc da_setup_obs_structures.inc da_setup_flow_predictors.inc da_setup_flow_predictors_para_read_opt1.inc da_chgvres.inc da_setup_cv.inc da_setup_be_nmm_regional.inc da_setup_be_regional.inc da_setup_be_ncep_gfs.inc da_setup_be_global.inc da_setup_background_errors.inc da_scale_background_errors.inc da_scale_background_errors_cv3.inc da_rescale_background_errors.inc da_interpolate_regcoeff.inc da_get_vertical_truncation.inc gsi_thinning.o module_radiance.o da_rf_cv3.o da_rfz_cv3.o da_vtox_transforms.o da_tracing.o da_tools.o da_tools_serial.o da_ssmi.o da_spectral.o da_recursive_filter.o da_reporting.o da_radiance.o da_par_util.o da_par_util1.o da_obs_io.o da_obs.o da_control.o da_wrf_interfaces.o da_define_structures.o module_domain.o da_wavelet.o da_chg_be_Vres.inc da_gen_eigen.inc da_eigen_to_covmatrix.inc da_setup_pseudo_obs.inc da_setup_flow_predictors_ep_format2.inc da_setup_flow_predictors_ep_format3.inc da_get_alpha_vertloc.inc da_write_vp.inc module_state_description.o da_setup_obs_structures_chem_sfc.inc da_ships.o : da_ships.f90 da_calculate_grady_ships.inc da_get_innov_vector_ships.inc da_check_max_iv_ships.inc da_transform_xtoy_ships_adj.inc da_transform_xtoy_ships.inc da_print_stats_ships.inc da_oi_stats_ships.inc da_residual_ships.inc da_jo_and_grady_ships.inc da_ao_stats_ships.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_sound.o : da_sound.f90 da_calculate_grady_sonde_sfc.inc da_check_max_iv_sonde_sfc.inc da_get_innov_vector_sonde_sfc.inc da_transform_xtoy_sonde_sfc_adj.inc da_transform_xtoy_sonde_sfc.inc da_print_stats_sonde_sfc.inc da_oi_stats_sonde_sfc.inc da_residual_sonde_sfc.inc da_jo_sonde_sfc_uvtq.inc da_jo_and_grady_sonde_sfc.inc da_ao_stats_sonde_sfc.inc da_check_buddy_sound.inc da_calculate_grady_sound.inc da_get_innov_vector_sound.inc da_check_max_iv_sound.inc da_transform_xtoy_sound_adj.inc da_transform_xtoy_sound.inc da_print_stats_sound.inc da_oi_stats_sound.inc da_residual_sound.inc da_jo_sound_uvtq.inc da_jo_and_grady_sound.inc da_ao_stats_sound.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_spectral.o : da_spectral.f90 da_apply_power.inc da_legtra_inv_adj.inc da_vtovv_spectral_adj.inc da_vv_to_v_spectral.inc da_vtovv_spectral.inc da_test_spectral.inc da_setlegpol.inc da_setlegpol_test.inc da_legtra.inc da_legtra_inv.inc da_initialize_h.inc da_get_reglats.inc da_get_gausslats.inc da_calc_power_spectrum.inc da_asslegpol.inc da_tracing.o da_tools_serial.o da_reporting.o da_par_util1.o da_define_structures.o da_control.o @@ -163,11 +164,11 @@ da_statistics.o : da_statistics.f90 da_print_qcstat.inc da_stats_calculate.inc d da_synop.o : da_synop.f90 da_check_buddy_synop.inc da_calculate_grady_synop.inc da_check_max_iv_synop.inc da_get_innov_vector_synop.inc da_transform_xtoy_synop_adj.inc da_transform_xtoy_synop.inc da_print_stats_synop.inc da_oi_stats_synop.inc da_residual_synop.inc da_jo_synop_uvtq.inc da_jo_and_grady_synop.inc da_ao_stats_synop.inc da_tracing.o da_tools.o da_statistics.o da_physics.o da_grid_definitions.o da_par_util.o da_par_util1.o da_interpolation.o da_define_structures.o da_control.o module_domain.o da_tamdar.o : da_tamdar.f90 da_calculate_grady_tamdar_sfc.inc da_check_max_iv_tamdar_sfc.inc da_get_innov_vector_tamdar_sfc.inc da_transform_xtoy_tamdar_sfc_adj.inc da_transform_xtoy_tamdar_sfc.inc da_print_stats_tamdar_sfc.inc da_oi_stats_tamdar_sfc.inc da_residual_tamdar_sfc.inc da_jo_tamdar_sfc_uvtq.inc da_jo_and_grady_tamdar_sfc.inc da_ao_stats_tamdar_sfc.inc da_calculate_grady_tamdar.inc da_get_innov_vector_tamdar.inc da_check_max_iv_tamdar.inc da_transform_xtoy_tamdar_adj.inc da_transform_xtoy_tamdar.inc da_print_stats_tamdar.inc da_oi_stats_tamdar.inc da_residual_tamdar.inc da_jo_tamdar_uvtq.inc da_jo_and_grady_tamdar.inc da_ao_stats_tamdar.inc da_tracing.o da_physics.o da_grid_definitions.o da_par_util1.o da_par_util.o da_tools.o da_statistics.o da_interpolation.o module_domain.o da_define_structures.o da_control.o da_varbc_tamdar.o da_varbc_tamdar.o : da_varbc_tamdar.f90 da_varbc_tamdar_init.inc da_varbc_tamdar_pred.inc da_varbc_tamdar_precond.inc da_varbc_tamdar_direct.inc da_varbc_tamdar_adj.inc da_varbc_tamdar_tl.inc da_varbc_tamdar_update.inc da_tracing.o da_tools_serial.o da_tools.o da_reporting.o da_define_structures.o da_control.o module_dm.o -da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_lhs_value.inc da_check_vtoy_adjoint.inc da_set_tst_trnsf_fld.inc da_check_psfc.inc da_check_sfc_assi.inc da_setup_testfield.inc da_check_xtoy_adjoint_buoy.inc da_check_xtoy_adjoint_profiler.inc da_check_xtoy_adjoint_ssmt2.inc da_check_xtoy_adjoint_ssmt1.inc da_check_xtoy_adjoint_qscat.inc da_check_xtoy_adjoint_pseudo.inc da_dot_cv.inc da_dot.inc da_check.inc da_check_gradient.inc da_transform_xtovp.inc da_check_xtoy_adjoint_rad.inc da_check_xtoy_adjoint_synop.inc da_check_xtoy_adjoint_tamdar_sfc.inc da_check_xtoy_adjoint_tamdar.inc da_check_xtoy_adjoint_mtgirs.inc da_check_xtoy_adjoint_sonde_sfc.inc da_check_xtoy_adjoint_sound.inc da_check_xtoy_adjoint_bogus.inc da_check_xtoy_adjoint_rain.inc da_check_xtoy_adjoint_radar.inc da_check_xtoy_adjoint_ships.inc da_check_xtoy_adjoint_polaramv.inc da_check_xtoy_adjoint_geoamv.inc da_check_xtoy_adjoint_satem.inc da_check_xtoy_adjoint_ssmi_tb.inc da_check_xtoy_adjoint_ssmi_rv.inc da_check_xtoy_adjoint_pilot.inc da_check_xtoy_adjoint_metar.inc da_check_xtoy_adjoint_gpsref.inc da_check_xtoy_adjoint_gpspw.inc da_check_xtoy_adjoint_airep.inc da_check_xtoy_adjoint.inc da_check_xtovptox_errors.inc da_check_vvtovp_adjoint.inc da_check_vp_errors.inc da_check_vptox_adjoint.inc da_check_vtox_adjoint.inc da_check_cvtovv_adjoint.inc da_check_balance.inc da_4dvar.o da_vtox_transforms.o da_wrfvar_io.o da_wrf_interfaces.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_ssmi.o da_spectral.o da_reporting.o da_physics.o da_par_util1.o da_par_util.o da_obs.o da_minimisation.o da_ffts.o da_dynamics.o da_define_structures.o module_state_description.o module_domain.o da_control.o module_comm_dm.o module_dm.o module_configure.o da_rain.o da_check_dynamics_adjoint.inc da_check_xtoy_adjoint_gpseph.inc da_check_cvtovv_adjoint_chem.inc da_check_vtox_adjoint_chem.inc da_check_vchemtox_adjoint.inc -da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc +da_test.o : da_test.f90 da_test_vxtransform.inc da_check_gradient.inc da_get_y_lhs_value.inc da_check_vtoy_adjoint.inc da_set_tst_trnsf_fld.inc da_check_psfc.inc da_check_sfc_assi.inc da_setup_testfield.inc da_check_xtoy_adjoint_buoy.inc da_check_xtoy_adjoint_profiler.inc da_check_xtoy_adjoint_ssmt2.inc da_check_xtoy_adjoint_ssmt1.inc da_check_xtoy_adjoint_qscat.inc da_check_xtoy_adjoint_pseudo.inc da_dot_cv.inc da_dot.inc da_check.inc da_check_gradient.inc da_transform_xtovp.inc da_check_xtoy_adjoint_rad.inc da_check_xtoy_adjoint_synop.inc da_check_xtoy_adjoint_tamdar_sfc.inc da_check_xtoy_adjoint_tamdar.inc da_check_xtoy_adjoint_mtgirs.inc da_check_xtoy_adjoint_sonde_sfc.inc da_check_xtoy_adjoint_sound.inc da_check_xtoy_adjoint_bogus.inc da_check_xtoy_adjoint_rain.inc da_check_xtoy_adjoint_radar.inc da_check_xtoy_adjoint_lightning.inc da_check_xtoy_adjoint_ships.inc da_check_xtoy_adjoint_polaramv.inc da_check_xtoy_adjoint_geoamv.inc da_check_xtoy_adjoint_satem.inc da_check_xtoy_adjoint_ssmi_tb.inc da_check_xtoy_adjoint_ssmi_rv.inc da_check_xtoy_adjoint_pilot.inc da_check_xtoy_adjoint_metar.inc da_check_xtoy_adjoint_gpsref.inc da_check_xtoy_adjoint_gpspw.inc da_check_xtoy_adjoint_airep.inc da_check_xtoy_adjoint.inc da_check_xtovptox_errors.inc da_check_vvtovp_adjoint.inc da_check_vp_errors.inc da_check_vptox_adjoint.inc da_check_vtox_adjoint.inc da_check_cvtovv_adjoint.inc da_check_balance.inc da_4dvar.o da_vtox_transforms.o da_wrfvar_io.o da_wrf_interfaces.o da_transfer_model.o da_tracing.o da_tools_serial.o da_statistics.o da_ssmi.o da_spectral.o da_reporting.o da_physics.o da_par_util1.o da_par_util.o da_obs.o da_minimisation.o da_ffts.o da_dynamics.o da_define_structures.o module_state_description.o module_domain.o da_control.o module_comm_dm.o module_dm.o module_configure.o da_rain.o da_check_dynamics_adjoint.inc da_check_xtoy_adjoint_gpseph.inc da_check_cvtovv_adjoint_chem.inc da_check_vtox_adjoint_chem.inc da_check_vchemtox_adjoint.inc +da_tools.o : da_tools.f90 da_geo2msl1.inc da_msl2geo1.inc da_get_time_slots.inc da_get_julian_time.inc da_get_print_lvl.inc da_get_3d_sum.inc da_get_2d_sum.inc da_set_boundary_3d.inc da_set_boundary_xb.inc da_set_boundary_xa.inc da_ludcmp.inc da_lubksb.inc da_eof_decomposition.inc da_eof_decomposition_test.inc da_buddy_qc.inc da_unifva.inc da_togrid.inc da_togrid_new.inc da_smooth_anl.inc da_openfile.inc da_gaus_noise.inc da_set_randomcv.inc da_random_omb.inc da_max_error_qc.inc da_add_noise_new.inc da_add_noise.inc da_residual_new.inc da_residual.inc da_diff_seconds.inc da_mo_correction.inc da_intpsfc_tem.inc da_intpsfc_prs.inc da_sfcprs.inc da_obs_sfc_correction.inc da_1d_eigendecomposition.inc da_convert_zk.inc da_lc_cone.inc da_set_merc.inc da_map_set.inc da_map_init.inc da_set_ps.inc da_set_lc.inc da_xyll_ps.inc da_xyll_merc.inc da_xyll_lc.inc da_xyll_latlon.inc da_xyll_default.inc da_xyll.inc da_llxy_wrf_new.inc da_llxy_wrf.inc da_llxy_ps_new.inc da_llxy_ps.inc da_llxy_merc_new.inc da_llxy_merc.inc da_llxy_lc_new.inc da_llxy_lc.inc da_llxy_latlon_new.inc da_llxy_latlon.inc da_llxy_rotated_latlon.inc da_llxy_global_new.inc da_llxy_global.inc da_llxy_kma_global_new.inc da_llxy_kma_global.inc da_llxy_default_new.inc da_llxy_default.inc da_llxy_new.inc da_llxy.inc da_llxy_1d.inc da_llxy_default_1d.inc da_llxy_global_1d.inc da_llxy_kma_global_1d.inc da_llxy_latlon_1d.inc da_llxy_lc_1d.inc da_llxy_merc_1d.inc da_llxy_ps_1d.inc da_llxy_rotated_latlon_1d.inc da_llxy_wrf_1d.inc da_togrid_1d.inc da_map_utils_defines.inc da_lapack.o da_reporting.o da_tracing.o da_tools_serial.o da_define_structures.o da_control.o module_domain.o module_dm.o module_bc.o da_sfc_hori_interp_weights.inc da_tools_serial.o : da_tools_serial.f90 da_find_fft_trig_funcs.inc da_find_fft_factors.inc da_advance_time.inc da_advance_cymdh.inc da_array_print.inc da_change_date.inc da_free_unit.inc da_get_unit.inc da_reporting.o da_control.o da_tracing.o : da_tracing.f90 da_trace_report.inc da_trace_real_sort.inc da_trace_int_sort.inc da_trace_exit.inc da_trace.inc da_trace_entry.inc da_trace_init.inc da_reporting.o da_par_util1.o da_control.o -da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_wrf_interfaces.o da_radar.o da_transfer_wrftoxb_chem.inc +da_transfer_model.o : da_transfer_model.f90 da_get_2nd_firstguess.inc da_setup_firstguess_kma.inc da_setup_firstguess_wrf_nmm_regional.inc da_setup_firstguess_wrf.inc da_setup_firstguess.inc da_transfer_xatoanalysis.inc da_transfer_wrftl_lbc_t0_adj.inc da_transfer_xatowrftl_adj_lbc.inc da_transfer_xatowrftl_adj.inc da_transfer_wrftl_lbc_t0.inc da_transfer_xatowrftl_lbc.inc da_transfer_xatowrftl.inc da_transfer_wrftltoxa_adj.inc da_transfer_wrftltoxa.inc da_transfer_xatokma.inc da_transfer_xatowrf_nmm_regional.inc da_transfer_xatowrf.inc da_transfer_kmatoxb.inc da_transfer_wrf_nmm_regional_toxb.inc da_transfer_wrftoxb.inc module_io_wrf.o module_bc.o da_4dvar.o da_vtox_transforms.o da_tracing.o da_tools.o da_ssmi.o da_setup_structures.o da_reporting.o da_physics.o da_par_util.o da_grid_definitions.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_state_description.o module_io_domain.o module_domain.o module_date_time.o module_configure.o da_wrf_interfaces.o da_radar.o da_lightning.o da_transfer_wrftoxb_chem.inc da_tune_obs_desroziers.o : da_tune_obs_desroziers.f90 da_tune_obs_hollingsworth1.o : da_tune_obs_hollingsworth1.f90 da_control.o da_tune_obs_hollingsworth2.o : da_tune_obs_hollingsworth2.f90 da_control.o @@ -191,7 +192,7 @@ da_wrfvar_esmf.o : da_wrfvar_esmf.f90 da_wrfvar_esmf_super.o : da_wrfvar_esmf_super.f90 da_wrfvar_interface.inc da_esmf_finalize.inc da_esmf_run.inc da_esmf_init.inc da_wrfvar_io.o : copyfile.c da_wrfvar_io.f90 da_med_initialdata_output_lbc.inc da_med_initialdata_output.inc da_med_initialdata_input.inc da_update_firstguess.inc da_4dvar.o da_tracing.o da_reporting.o da_control.o module_io_domain.o module_domain.o module_date_time.o module_configure.o module_domain_type.o da_wrfvar_main.o : da_wrfvar_main.f90 da_4dvar.o da_wrfvar_top.o da_wrf_interfaces.o da_tracing.o da_control.o module_symbols_util.o -da_wrfvar_top.o : da_wrfvar_top.f90 da_solve_init.inc da_solve_dual_res_init.inc da_solve.inc da_wrfvar_finalize.inc da_wrfvar_interface.inc da_wrfvar_run.inc da_wrfvar_init2.inc da_wrfvar_init1.inc da_wrf_interfaces.o da_rain.o da_synop.o da_ssmi.o da_sound.o da_ships.o da_satem.o da_radar.o da_mtgirs.o da_qscat.o da_profiler.o da_polaramv.o da_pilot.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_buoy.o da_bogus.o da_airsr.o da_airep.o da_crtm.o da_tools.o da_vtox_transforms.o da_transfer_model.o da_tracing.o da_tools_serial.o da_test.o da_setup_structures.o da_reporting.o da_varbc.o da_radiance1.o da_physics.o da_par_util.o da_obs_io.o da_obs.o da_minimisation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_tiles.o module_state_description.o module_radiance.o da_wrfvar_io.o da_4dvar.o module_symbols_util.o module_driver_constants.o module_domain.o module_configure.o module_io_domain.o da_netcdf_interface.o da_gpseph.o da_varbc_tamdar.o module_io_wrf.o da_chem_sfc.o +da_wrfvar_top.o : da_wrfvar_top.f90 da_solve_init.inc da_solve_dual_res_init.inc da_solve.inc da_wrfvar_finalize.inc da_wrfvar_interface.inc da_wrfvar_run.inc da_wrfvar_init2.inc da_wrfvar_init1.inc da_wrf_interfaces.o da_rain.o da_synop.o da_ssmi.o da_sound.o da_ships.o da_satem.o da_radar.o da_lightning.o da_mtgirs.o da_qscat.o da_profiler.o da_polaramv.o da_pilot.o da_metar.o da_gpsref.o da_gpspw.o da_geoamv.o da_buoy.o da_bogus.o da_airsr.o da_airep.o da_crtm.o da_tools.o da_vtox_transforms.o da_transfer_model.o da_tracing.o da_tools_serial.o da_test.o da_setup_structures.o da_reporting.o da_varbc.o da_radiance1.o da_physics.o da_par_util.o da_obs_io.o da_obs.o da_minimisation.o da_define_structures.o da_control.o module_comm_dm.o module_dm.o module_tiles.o module_state_description.o module_radiance.o da_wrfvar_io.o da_4dvar.o module_symbols_util.o module_driver_constants.o module_domain.o module_configure.o module_io_domain.o da_netcdf_interface.o da_gpseph.o da_varbc_tamdar.o module_io_wrf.o da_chem_sfc.o decode_airs.o : decode_airs.f90 module_read_airs.o f_qv_from_rh.o : f_qv_from_rh.f90 gamma1.o : gamma1.f90 da_control.o diff --git a/var/da/da_control/da_control.f90 b/var/da/da_control/da_control.f90 index 5abe3ff927..46810d7bec 100644 --- a/var/da/da_control/da_control.f90 +++ b/var/da/da_control/da_control.f90 @@ -240,6 +240,7 @@ module da_control real, parameter :: typical_rv_rms = 1.0 ! m/s real, parameter :: typical_rf_rms = 1.0 ! dBZ real, parameter :: typical_rain_rms = 1.0 ! mm + real, parameter :: typical_div_rms = 0.001 ! The following typical mean squared values depend on control variable. They ! are calculated in da_setup_background_errors and used in the VvToVp adjoint @@ -487,7 +488,7 @@ module da_control ! rtm_init setup parameter - integer, parameter :: maxsensor = 30 + integer, parameter :: maxsensor = 31 integer, parameter :: npres_print = 12 @@ -525,8 +526,9 @@ module da_control integer, parameter :: tamdar_sfc = 27 integer, parameter :: rain = 28 integer, parameter :: gpseph = 29 + integer, parameter :: lightning = 30 #if (WRF_CHEM == 1) - integer, parameter :: chemic_surf = 30 + integer, parameter :: chemic_surf = 31 #endif character(len=14), parameter :: obs_names(num_ob_indexes) = (/ & @@ -558,7 +560,8 @@ module da_control "tamdar ", & "tamdar_sfc ", & "rain ", & - "gpseph " & + "gpseph ", & + "lightning " & #if (WRF_CHEM == 1) ,"chemic_surf " & #endif diff --git a/var/da/da_define_structures/da_allocate_observations.inc b/var/da/da_define_structures/da_allocate_observations.inc index 3c631deb39..90cf02f120 100644 --- a/var/da/da_define_structures/da_allocate_observations.inc +++ b/var/da/da_define_structures/da_allocate_observations.inc @@ -36,6 +36,7 @@ subroutine da_allocate_observations (iv) if (iv%info(profiler)%nlocal > 0) allocate(iv%profiler (1:iv%info(profiler)%nlocal)) if (iv%info(buoy)%nlocal > 0) allocate(iv%buoy (1:iv%info(buoy)%nlocal)) if (iv%info(radar)%nlocal > 0) allocate(iv%radar (1:iv%info(radar)%nlocal)) + if (iv%info(lightning)%nlocal > 0) allocate(iv%lightning(1:iv%info(lightning)%nlocal)) if (iv%info(bogus)%nlocal > 0) allocate(iv%bogus (1:iv%info(bogus)%nlocal)) if (iv%info(airsr)%nlocal > 0) allocate(iv%airsr (1:iv%info(airsr)%nlocal)) diff --git a/var/da/da_define_structures/da_allocate_y.inc b/var/da/da_define_structures/da_allocate_y.inc index 13935e1a52..f206bebb5b 100644 --- a/var/da/da_define_structures/da_allocate_y.inc +++ b/var/da/da_define_structures/da_allocate_y.inc @@ -211,6 +211,19 @@ subroutine da_allocate_y (iv, y) end do end if + if (y % nlocal(lightning) > 0) then + allocate (y % lightning(1:y % nlocal(lightning))) + do n = 1, y % nlocal(lightning) + nlevels = iv%info(lightning)%levels(n) + allocate (y % lightning(n) % w(1:nlevels)) + allocate (y % lightning(n) % div(1:nlevels)) + allocate (y % lightning(n) % qv(1:nlevels)) + y % lightning(n) % w(1:nlevels) = 0.0 + y % lightning(n) % div(1:nlevels) = 0.0 + y % lightning(n) % qv(1:nlevels) = 0.0 + end do + end if + if (y % nlocal(airep) > 0) then allocate (y % airep(1:y % nlocal(airep))) do n = 1, y % nlocal(airep) diff --git a/var/da/da_define_structures/da_allocate_y_lightning.inc b/var/da/da_define_structures/da_allocate_y_lightning.inc new file mode 100644 index 0000000000..5222f34e84 --- /dev/null +++ b/var/da/da_define_structures/da_allocate_y_lightning.inc @@ -0,0 +1,44 @@ +subroutine da_allocate_y_lightning (iv, y) + + !--------------------------------------------------------------------------- + ! Purpose: Allocate arrays used in y and residual obs structures. + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !--------------------------------------------------------------------------- + + implicit none + + type (iv_type), intent(in) :: iv ! Ob type input. + type (y_type), intent(inout) :: y ! Residual type structure. + + integer :: n ! Loop counter. + integer :: nlevels ! Number of levels. + + !--------------------------------------------------------------------------- + ! [1.0] Copy number of observations: + !--------------------------------------------------------------------------- + + if (trace_use) call da_trace_entry("da_allocate_y_lightning") + + y % nlocal(lightning) = iv%info(lightning)%nlocal + y % ntotal(lightning) = iv%info(lightning)%ntotal + + !--------------------------------------------------------------------------- + ! [2.0] Allocate: + !--------------------------------------------------------------------------- + + if (y % nlocal(lightning) > 0) then + allocate (y % lightning(1:y % nlocal(lightning))) + do n = 1, y % nlocal(lightning) + nlevels = iv%info(lightning)%levels(n) + allocate (y % lightning(n) % w(1:nlevels)) + allocate (y % lightning(n) % div(1:nlevels)) + allocate (y % lightning(n) % qv(1:nlevels)) + y % lightning(n) % w(1:nlevels) = 0.0 + y % lightning(n) % div(1:nlevels) = 0.0 + y % lightning(n) % qv(1:nlevels) = 0.0 + end do + end if + + if (trace_use) call da_trace_exit("da_allocate_y_lightning") + +end subroutine da_allocate_y_lightning diff --git a/var/da/da_define_structures/da_deallocate_observations.inc b/var/da/da_define_structures/da_deallocate_observations.inc index c98a0ca210..041e56448a 100644 --- a/var/da/da_define_structures/da_deallocate_observations.inc +++ b/var/da/da_define_structures/da_deallocate_observations.inc @@ -157,6 +157,15 @@ subroutine da_deallocate_observations (iv) deallocate (iv%radar) end if + if (iv%info(lightning)%nlocal > 0) then + do n = 1, iv%info(lightning)%nlocal + deallocate (iv%lightning(n) % w) + deallocate (iv%lightning(n) % div) + deallocate (iv%lightning(n) % qv) + end do + deallocate (iv%lightning) + end if + if (iv%info(rain)%nlocal > 0) deallocate (iv%rain) if (iv%info(gpspw)%nlocal > 0) deallocate (iv%gpspw) diff --git a/var/da/da_define_structures/da_deallocate_y.inc b/var/da/da_define_structures/da_deallocate_y.inc index 3225ac90c6..25fc969836 100644 --- a/var/da/da_define_structures/da_deallocate_y.inc +++ b/var/da/da_define_structures/da_deallocate_y.inc @@ -81,18 +81,26 @@ subroutine da_deallocate_y(y) deallocate (y % bogus) end if - if (y % nlocal(radar) > 0) then - do n = 1, y % nlocal(radar) - deallocate (y % radar(n)%rv) - deallocate (y % radar(n)%rf) - if (associated(y%radar(n)%rqv)) deallocate(y%radar(n)%rqv) - if (associated(y%radar(n)%rgr)) deallocate(y%radar(n)%rgr) - if (associated(y%radar(n)%rsn)) deallocate(y%radar(n)%rsn) - if (associated(y%radar(n)%rrn)) deallocate(y%radar(n)%rrn) - end do - deallocate (y % radar) - end if + if (y % nlocal(radar) > 0) then + do n = 1, y % nlocal(radar) + deallocate (y % radar(n)%rv) + deallocate (y % radar(n)%rf) + if (associated(y%radar(n)%rqv)) deallocate(y%radar(n)%rqv) + if (associated(y%radar(n)%rgr)) deallocate(y%radar(n)%rgr) + if (associated(y%radar(n)%rsn)) deallocate(y%radar(n)%rsn) + if (associated(y%radar(n)%rrn)) deallocate(y%radar(n)%rrn) + end do + deallocate (y % radar) + end if + if (y % nlocal(lightning) > 0) then + do n = 1, y % nlocal(lightning) + deallocate (y % lightning(n)%w) + deallocate (y % lightning(n)%div) + deallocate (y % lightning(n)%qv) + end do + deallocate (y % lightning) + end if if (y % nlocal(airep) > 0) then do n = 1, y % nlocal(airep) diff --git a/var/da/da_define_structures/da_define_structures.f90 b/var/da/da_define_structures/da_define_structures.f90 index 7d3249e4c0..2ecff3eaaa 100644 --- a/var/da/da_define_structures/da_define_structures.f90 +++ b/var/da/da_define_structures/da_define_structures.f90 @@ -21,7 +21,7 @@ module da_define_structures put_rand_seed, seed_array1, seed_array2, missing_r, & sound, synop, pilot, satem, geoamv, polaramv, airep, gpspw, gpsref, gpseph, & metar, ships, ssmi_rv, ssmi_tb, ssmt1, ssmt2, qscat, profiler, buoy, bogus, & - mtgirs, tamdar, tamdar_sfc, pseudo, radar, radiance, airsr, sonde_sfc, rain, & + mtgirs, tamdar, tamdar_sfc, pseudo, radar, lightning, radiance, airsr, sonde_sfc, rain, & #if (WRF_CHEM == 1) chemic_surf, chem_cv_options, & #endif @@ -318,6 +318,42 @@ module da_define_structures type (rain_each_type) :: each(1) end type rain_single_level_type + type lightning_stn_type + character (len = 5) :: platform ! Data type + character (len = 12) :: name ! Station name + character (len = 19) :: date_char ! CCYY-MM-DD_HH:MM:SS date + integer :: numobs ! number of Obs + integer :: levels ! number of levels + real :: lat ! Latitude in degree + real :: lon ! Longitude in degree + real :: elv ! Elevation in + end type lightning_stn_type + + type lightning_type + type (stn_loc_type) :: stn_loc + real , pointer :: height (:) ! Height in m + integer , pointer :: height_qc(:) ! Height QC + type (field_type) , pointer :: w(:) ! Retrieved vertical velocity from flash rate + type (field_type) , pointer :: div(:) ! Retrieved convergence fileds from vertical velocity + type (field_type) , pointer :: qv(:) ! Retrieved vapor mixing ratio from flash rate + end type lightning_type + + type lightning_each_level_type + real :: height ! Height in m + integer :: height_qc ! Height QC + real :: zk ! MM5 k-coordinates + type (field_type) :: w + type (field_type) :: div + type (field_type) :: qv + end type lightning_each_level_type + + type lightning_multi_level_type + type (lightning_stn_type) :: stn + type (info_type) :: info + type (model_loc_type) :: loc + type (lightning_each_level_type) :: each(max_ob_levels) + end type lightning_multi_level_type + #if (WRF_CHEM == 1) type chemic_surf_type @@ -538,10 +574,12 @@ module da_define_structures real, pointer :: vtox(:,:) end type varbc_type type clddet_geoir_type - real :: RTCT, RFMFT, TEMPIR, terr_hgt - real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 - real :: CIRH2O - !real, allocatable :: CIRH2O(:,:,:) + real :: RTCT, RFMFT, TEMPIR, terr_hgt ! for both ABI and AHI + real :: tb_stddev_10, tb_stddev_13,tb_stddev_14 ! only for AHI + real :: CIRH2O ! for both ABI and AHI + real, allocatable :: CIRH2O_abi(:,:,:) ! only for ABI + real, allocatable :: tb_stddev_3x3(:) ! only for ABI + integer :: RFMFT_ij(2) ! only for ABI end type clddet_geoir_type type superob_type real, allocatable :: tb_obs(:,:) @@ -582,6 +620,8 @@ module da_define_structures integer, pointer :: cloud_flag(:,:) integer, pointer :: cloudflag(:) integer, pointer :: rain_flag(:) + real, pointer :: cloud_mod(:,:) ! only for ABI + real, pointer :: cloud_obs(:,:) ! only for ABI real, allocatable :: cloud_frac(:) real, pointer :: satzen(:) real, pointer :: satazi(:) @@ -596,10 +636,10 @@ module da_define_structures real, pointer :: lod(:,:,:) ! layer_optical_depth real, pointer :: trans(:,:,:) ! layer transmittance real, pointer :: der_trans(:,:,:) ! d(transmittance)/dp - real, pointer :: kmin_t(:) - real, pointer :: kmax_p(:) - real, pointer :: sensitivity_ratio(:,:,:) - real, pointer :: p_chan_level(:,:) + real, pointer :: kmin_t(:) + real, pointer :: kmax_p(:) + real, pointer :: sensitivity_ratio(:,:,:) + real, pointer :: p_chan_level(:,:) real, pointer :: qrn(:,:) real, pointer :: qcw(:,:) real, pointer :: qci(:,:) @@ -702,6 +742,7 @@ module da_define_structures real :: bogus_ef_u, bogus_ef_v, bogus_ef_t, bogus_ef_p, bogus_ef_q, bogus_ef_slp real :: airsr_ef_t, airsr_ef_q real :: rain_ef_r + real :: lightning_ef_w, lightning_ef_div, lightning_ef_qv #if (WRF_CHEM == 1) real :: chemic_surf_ef #endif @@ -737,6 +778,7 @@ module da_define_structures type (tamdar_type) , pointer :: tamdar(:) type (synop_type) , pointer :: tamdar_sfc(:) type (rain_type) , pointer :: rain(:) + type (lightning_type), pointer :: lightning(:) #if (WRF_CHEM == 1) type (chemic_surf_type), pointer :: chemic_surf(:) #endif @@ -782,6 +824,8 @@ module da_define_structures type (bad_info_type) :: slp type (bad_info_type) :: rad type (bad_info_type) :: rain + type (bad_info_type) :: w + type (bad_info_type) :: div #if (WRF_CHEM == 1) type (bad_info_type) :: chemic_surf #endif @@ -928,6 +972,12 @@ module da_define_structures real, pointer :: rqv(:) => null() end type residual_radar_type + type residual_lightning_type + real, pointer :: w(:) + real, pointer :: div(:) + real, pointer :: qv(:) + end type residual_lightning_type + type residual_instid_type integer :: num_rad integer :: nchan @@ -985,6 +1035,7 @@ module da_define_structures type (residual_radar_type), pointer :: radar(:) type (residual_instid_type), pointer :: instid(:) type (residual_rain_type), pointer :: rain(:) + type (residual_lightning_type),pointer :: lightning(:) #if (WRF_CHEM == 1) type (residual_chem_surf_type),pointer :: chemic_surf(:) #endif @@ -1039,6 +1090,7 @@ module da_define_structures real :: bogus_u, bogus_v, bogus_t, bogus_q, bogus_slp real :: airsr_t, airsr_q real :: rain_r + real :: lightning_w, lightning_div, lightning_qv #if (WRF_CHEM == 1) real :: chemic_surf #endif @@ -1216,6 +1268,7 @@ module da_define_structures #endif #include "da_allocate_y.inc" #include "da_allocate_y_radar.inc" +#include "da_allocate_y_lightning.inc" #include "da_allocate_y_rain.inc" #if (WRF_CHEM == 1) #include "da_allocate_y_chem_sfc.inc" diff --git a/var/da/da_define_structures/da_zero_y.inc b/var/da/da_define_structures/da_zero_y.inc index 09bae42319..822be34ba9 100644 --- a/var/da/da_define_structures/da_zero_y.inc +++ b/var/da/da_define_structures/da_zero_y.inc @@ -284,6 +284,17 @@ subroutine da_zero_y( iv, y, value ) end do end if + ! Initialize lightning: + if ( y % nlocal(lightning) > 0 ) then + do n = 1, y % nlocal(lightning) + nlevels = iv % info(lightning) % levels(n) + + y % lightning(n) % w(1:nlevels) = value + y % lightning(n) % div(1:nlevels) = value + y % lightning(n) % qv(1:nlevels) = value + end do + end if + ! Initialize rain: if ( y % nlocal(rain) > 0 ) then y % rain(1:y % nlocal(rain)) % rain = value diff --git a/var/da/da_lightning/da_ao_stats_lightning.inc b/var/da/da_lightning/da_ao_stats_lightning.inc new file mode 100644 index 0000000000..47b97352ce --- /dev/null +++ b/var/da/da_lightning/da_ao_stats_lightning.inc @@ -0,0 +1,96 @@ +subroutine da_ao_stats_lightning (stats_unit, iv, re) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + integer, intent (in) :: stats_unit ! Output unit for stats. + type (iv_type), intent (inout) :: iv ! iv + type (y_type), intent (in) :: re ! A - O + + type (stats_lightning_type) :: stats + integer :: nw, ndiv, nqv + integer :: n, k + + if (trace_use_dull) call da_trace_entry("da_ao_stats_lightning") + + nw = 0 + ndiv = 0 + nqv = 0 + + stats%maximum%w = maxmin_type (missing_r, 0, 0) + stats%maximum%div = maxmin_type (missing_r, 0, 0) + stats%maximum%qv = maxmin_type (missing_r, 0, 0) + stats%minimum%w = maxmin_type(-missing_r, 0, 0) + stats%minimum%div = maxmin_type(-missing_r, 0, 0) + stats%minimum%qv = maxmin_type(-missing_r, 0, 0) + + stats%average = residual_lightning1_type(0.0, 0.0, 0.0) + stats%rms_err = stats%average + + do n = 1, iv%info(lightning)%nlocal + if(iv%info(lightning)%proc_domain(1,n)) then + do k = 1, iv%info(lightning)%levels(n) + + if(use_lightning_w) then + call da_stats_calculate (n, k, iv%lightning(n)%w(k)%qc, & + re%lightning(n)%w(k), nw, & + stats%minimum%w, stats%maximum%w, & + stats%average%w, stats%rms_err%w) + end if + + if(use_lightning_div) then + call da_stats_calculate (n, k, iv%lightning(n)%div(k)%qc, & + re%lightning(n)%div(k), ndiv, & + stats%minimum%div, stats%maximum%div, & + stats%average%div, stats%rms_err%div) + end if + + if(use_lightning_qv) then + call da_stats_calculate (n, k, iv%lightning(n)%qv(k)%qc, & + re%lightning(n)%qv(k), nqv, & + stats%minimum%qv, stats%maximum%qv, & + stats%average%qv, stats%rms_err%qv) + end if + end do + end if + end do + + ! Do inter-processor communication to gather statistics. + if (use_lightning_w) then + call da_proc_sum_int (nw) + call da_proc_stats_combine(stats%average%w, stats%rms_err%w, & + stats%minimum%w%value, stats%maximum%w%value, & + stats%minimum%w%n, stats%maximum%w%n, & + stats%minimum%w%l, stats%maximum%w%l) + end if + + if (use_lightning_div) then + call da_proc_sum_int (ndiv) + call da_proc_stats_combine(stats%average%div, stats%rms_err%div, & + stats%minimum%div%value, stats%maximum%div%value, & + stats%minimum%div%n, stats%maximum%div%n, & + stats%minimum%div%l, stats%maximum%div%l) + end if + + if (use_lightning_qv) then + call da_proc_sum_int (nqv) + call da_proc_stats_combine(stats%average%qv, stats%rms_err%qv, & + stats%minimum%qv%value, stats%maximum%qv%value, & + stats%minimum%qv%n, stats%maximum%qv%n, & + stats%minimum%qv%l, stats%maximum%qv%l) + end if + + if (rootproc) then + if ( nw /= 0 .or. ndiv /= 0 .or. nqv /= 0 ) then + write(unit=stats_unit, fmt='(/a/)') ' Diagnostics of AO for lightning' + call da_print_stats_lightning(stats_unit, nw, ndiv, nqv, stats) + end if + end if + + if (trace_use_dull) call da_trace_exit("da_ao_stats_lightning") + +end subroutine da_ao_stats_lightning diff --git a/var/da/da_lightning/da_calculate_grady_lightning.inc b/var/da/da_lightning/da_calculate_grady_lightning.inc new file mode 100644 index 0000000000..58689124fa --- /dev/null +++ b/var/da/da_lightning/da_calculate_grady_lightning.inc @@ -0,0 +1,46 @@ +subroutine da_calculate_grady_lightning(iv, re, jo_grad_y) + + !---------------------------------------------------------------------- + ! Purpose: Applies obs inverse on re-vector + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !------------------------------------------------------------------------------ + implicit none + + type (iv_type), intent(in) :: iv ! Innovation vector. + type (y_type), intent(inout) :: re ! Residual vector. + type (y_type), intent(inout) :: jo_grad_y ! Grad_y(Jo) + + integer :: n, k + + if (trace_use_dull) call da_trace_entry("da_calculate_grady_lightning") + + do n = 1, iv%info(lightning)%nlocal + do k = 2, iv%info(lightning)%levels(n) + + if(use_lightning_w) then + if(iv%lightning(n)%w(k)%qc < obs_qc_pointer) then + re%lightning(n)%w(k) = 0.0 + end if + jo_grad_y%lightning(n)%w(k) = -re%lightning(n)%w(k) / (iv%lightning(n)%w(k)%error * iv%lightning(n)%w(k)%error) + end if + + if(use_lightning_div) then + if(iv%lightning(n)%div(k)%qc < obs_qc_pointer) then + re%lightning(n)%div(k) = 0.0 + end if + jo_grad_y%lightning(n)%div(k) = -re%lightning(n)%div(k) / (iv%lightning(n)%div(k)%error * iv%lightning(n)%div(k)%error) + end if + + if(use_lightning_qv) then + if(iv%lightning(n)%qv(k)%qc < obs_qc_pointer) then + re%lightning(n)%qv(k) = 0.0 + end if + jo_grad_y%lightning(n)%qv(k) = -re%lightning(n)%qv(k) / (iv%lightning(n)%qv(k)%error * iv%lightning(n)%qv(k)%error) + end if + + end do + end do + + if (trace_use_dull) call da_trace_exit("da_calculate_grady_lightning") + +end subroutine da_calculate_grady_lightning diff --git a/var/da/da_lightning/da_check_max_iv_lightning.inc b/var/da/da_lightning/da_check_max_iv_lightning.inc new file mode 100644 index 0000000000..e79cbe3673 --- /dev/null +++ b/var/da/da_lightning/da_check_max_iv_lightning.inc @@ -0,0 +1,62 @@ +subroutine da_check_max_iv_lightning(iv,ob, it) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + type(iv_type), intent(inout) :: iv + integer, intent(in) :: it ! Outer iteration + type(y_type), intent(in) :: ob ! Observation structure. + + logical :: failed + integer :: n, k + + if (trace_use) call da_trace_entry("da_check_max_iv_lightning") + + !--------------------------------------------------------------------------- + ! [1.0] Perform maximum innovation vector check: + !--------------------------------------------------------------------------- + + do n = iv%info(lightning)%n1,iv%info(lightning)%n2 + do k = 1, iv%info(lightning)%levels(n) + failed = .false. + if(iv%lightning(n)%w(k)%qc >= obs_qc_pointer) then + call da_max_error_qc(it, iv%info(lightning), n, iv%lightning(n)%w(k),max_error_lda_w, failed) + if(iv%info(lightning)%proc_domain(k,n)) then + if(failed) then + write(qcstat_conv_unit,'(2x, a10, 2x, a10, 4f12.3, a12)')& + 'Lightning','lightning',iv%info(lightning)%lat(k,n),iv%info(lightning)%lon(k,n), iv%lightning(n)%w(k)%inv, ob%lightning(n)%w(k) + end if + end if + end if + + failed = .false. + if(iv%lightning(n)%div(k)%qc >= obs_qc_pointer) then + call da_max_error_qc(it, iv%info(lightning), n, iv%lightning(n)%div(k),max_error_lda_div, failed) + if(iv%info(lightning)%proc_domain(k,n)) then + if(failed) then + write(qcstat_conv_unit,'(2x, a10, 2x, a10, 4f12.3, a12)')& + 'Lightning','lightning',iv%info(lightning)%lat(k,n),iv%info(lightning)%lon(k,n), iv%lightning(n)%div(k)%inv, ob%lightning(n)%div(k) + end if + end if + end if + + failed = .false. + if(iv%lightning(n)%qv(k)%qc >= obs_qc_pointer) then + call da_max_error_qc(it, iv%info(lightning), n, iv%lightning(n)%qv(k),max_error_lda_qv, failed) + if(iv%info(lightning)%proc_domain(k,n)) then + if(failed)then + write(qcstat_conv_unit,'(2x,a10,2x,a10,4f12.2,a12)')& + 'Lightning','lightning',iv%info(lightning)%lat(k,n),iv%info(lightning)%lon(k,n), iv%lightning(n)%qv(k)%inv, ob%lightning(n)%qv(k) + end if + end if + end if + end do + end do + + if (trace_use) call da_trace_exit("da_check_max_iv_lightning") + +end subroutine da_check_max_iv_lightning diff --git a/var/da/da_lightning/da_div_profile.inc b/var/da/da_lightning/da_div_profile.inc new file mode 100644 index 0000000000..9111112433 --- /dev/null +++ b/var/da/da_lightning/da_div_profile.inc @@ -0,0 +1,57 @@ +subroutine da_div_profile(grid, info, n, k, div) + + !-------------------------------------------------------------------------- + ! Purpose: Calculates divergence (div) on each level at the observed location (i,j). + ! dx, dxm, dy, dym are horizontal interpolation weighting. + ! d U d V + ! Div = m^2 *[---(---) + ---(---) ] + ! dx m dy m + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !-------------------------------------------------------------------------- + + implicit none + + type (domain), intent(in) :: grid + type (infa_type), intent(in) :: info + integer, intent(in) :: n, k + real, intent(out) :: div + + integer :: ii, jj ! index dimension. + real :: div_m(2,2) ! divergence + + integer :: i, j ! OBS location + real :: dx, dxm ! interpolation weights. + real :: dy, dym ! interpolation weights. + real :: coeff + if (trace_use_dull) call da_trace_entry("da_div_profile") + + i = info%i(1,n) + j = info%j(1,n) + dx = info%dx(1,n) + dy = info%dy(1,n) + dxm = info%dxm(1,n) + dym = info%dym(1,n) + + if(i == its) i = its + 1 + if(i == ite) i = ite - 1 + if(j == jts) j = jts + 1 + if(j == jte) j = jte - 1 + ! calculate layered divergence + + do ii = i, i+1 + do jj = j, j+1 + coeff = grid%xb%map_factor(ii,jj) * grid%xb%map_factor(ii,jj)*0.5/grid%xb%ds + + div_m(ii-i+1,jj-j+1) = (grid%xb%u(ii+1,jj,k)/grid%xb%map_factor(ii+1,jj) - & + grid%xb%u(ii-1,jj,k)/grid%xb%map_factor(ii-1,jj) + & + grid%xb%v(ii,jj+1,k)/grid%xb%map_factor(ii,jj+1) - & + grid%xb%v(ii,jj-1,k)/grid%xb%map_factor(ii,jj-1))*coeff + end do + end do + + ! Horizontal interpolation to the obs. pt. + div = dym*(dxm*div_m(1,1)+dx*div_m(2,1))+dy*(dxm*div_m(1,2)+dx*div_m(2,2)) + + if (trace_use_dull) call da_trace_exit("da_div_profile") + +end subroutine da_div_profile diff --git a/var/da/da_lightning/da_div_profile_adj.inc b/var/da/da_lightning/da_div_profile_adj.inc new file mode 100644 index 0000000000..80b7855920 --- /dev/null +++ b/var/da/da_lightning/da_div_profile_adj.inc @@ -0,0 +1,65 @@ +subroutine da_div_profile_adj(grid,jo_grad_x, info, n, k, ADJ_div) + + !-------------------------------------------------------------------------- + ! Purpose: Calculates divergence (div) on each level at the observed location (i,j). + ! dx, dxm, dy, dym are horizontal interpolation weighting. + ! d U d V + ! Div = m^2 *[---(---) + ---(---) ] + ! dx m dy M + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !-------------------------------------------------------------------------- + + implicit none + + type (x_type), intent(inout) :: jo_grad_x ! grad_x(jo) + type (domain), intent(in) :: grid + type (infa_type), intent(in) :: info + integer, intent(in) :: n, k + real, intent(out) :: ADJ_div + + integer :: ii, jj ! index dimension. + + integer :: i, j ! OBS location + real :: dx, dxm ! interpolation weights. + real :: dy, dym ! interpolation weights. + real :: coeff + real :: ADJ_div_m(2,2) + + if (trace_use_dull) call da_trace_entry ("da_div_profile_adj") + + i = info%i(1,n) + j = info%j(1,n) + dx = info%dx(1,n) + dy = info%dy(1,n) + dxm = info%dxm(1,n) + dym = info%dym(1,n) + +! avoid the boundary mistake + if(i == its) i = its + 1 + if(i == ite) i = ite - 1 + if(j == jts) j = jts + 1 + if(j == jte) j = jte - 1 + + ADJ_div_m(1,1) = dym*dxm * ADJ_div + ADJ_div_m(2,1) = dym*dx * ADJ_div + ADJ_div_m(1,2) = dy*dxm* ADJ_div + ADJ_div_m(2,2) = dy*dx* ADJ_div + ADJ_div = 0.0 + + do ii = i, i+1 + do jj = j, j+1 + coeff = grid%xb%map_factor(ii,jj) * grid%xb%map_factor(ii,jj)*0.5/grid%xb%ds + + jo_grad_x%u(ii+1,jj,k) = jo_grad_x%u(ii+1,jj,k) + ADJ_div_m(ii-i+1,jj-j+1)/grid%xb%map_factor(ii+1,jj)*coeff + + jo_grad_x%u(ii-1,jj,k) = jo_grad_x%u(ii-1,jj,k) - ADJ_div_m(ii-i+1,jj-j+1)/grid%xb%map_factor(ii-1,jj)*coeff + + jo_grad_x%v(ii,jj+1,k) = jo_grad_x%v(ii,jj+1,k) + ADJ_div_m(ii-i+1,jj-j+1)/grid%xb%map_factor(ii,jj+1)*coeff + + jo_grad_x%v(ii,jj-1,k) = jo_grad_x%v(ii,jj-1,k) - ADJ_div_m(ii-i+1,jj-j+1)/grid%xb%map_factor(ii,jj-1)*coeff + end do + end do + + if (trace_use_dull) call da_trace_exit("da_div_profile_adj") + +end subroutine da_div_profile_adj diff --git a/var/da/da_lightning/da_div_profile_tl.inc b/var/da/da_lightning/da_div_profile_tl.inc new file mode 100644 index 0000000000..a5c6aeb5e1 --- /dev/null +++ b/var/da/da_lightning/da_div_profile_tl.inc @@ -0,0 +1,58 @@ +subroutine da_div_profile_tl(grid, info, n, k, div) + + !-------------------------------------------------------------------------- + ! Purpose: Calculates divergence (div) on each level at the observed location (i,j). + ! dx, dxm, dy, dym are horizontal interpolation weighting. + ! d U d V + ! Div = m^2 *[---(---) + ---(---) ] + ! dx m dy M + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !-------------------------------------------------------------------------- + + implicit none + + type (domain), intent(in) :: grid + type (infa_type), intent(in) :: info + integer, intent(in) :: n, k + real, intent(inout) :: div + + integer :: ii, jj ! index dimension. + real :: div_m(2,2) ! divergence + + integer :: i, j ! OBS location + real :: dx, dxm ! interpolation weights. + real :: dy, dym ! interpolation weights. + real :: coeff + + if (trace_use_dull) call da_trace_entry("da_div_profile_tl") + + i = info%i(1,n) + j = info%j(1,n) + dx = info%dx(1,n) + dy = info%dy(1,n) + dxm = info%dxm(1,n) + dym = info%dym(1,n) + + ! calculate layered divergence + if(i == its) i = its + 1 + if(i == ite) i = ite - 1 + if(j == jts) j = jts + 1 + if(j == jte) j = jte - 1 + + do ii = i, i+1 + do jj = j, j+1 + coeff = grid%xb%map_factor(ii,jj)*grid%xb%map_factor(ii,jj)*0.5/grid%xb%ds + + div_m(ii-i+1,jj-j+1) = (grid%xa%u(ii+1,jj,k)/grid%xb%map_factor(ii+1,jj) - & + grid%xa%u(ii-1,jj,k)/grid%xb%map_factor(ii-1,jj) + & + grid%xa%v(ii,jj+1,k)/grid%xb%map_factor(ii,jj+1) - & + grid%xa%v(ii,jj-1,k)/grid%xb%map_factor(ii,jj-1))* coeff + end do + end do + + ! Horizontal interpolation to the obs. pt. + div = dym*(dxm*div_m(1,1)+dx*div_m(2,1))+dy*(dxm*div_m(1,2)+dx*div_m(2,2)) + + if (trace_use_dull) call da_trace_exit("da_div_profile_tl") + +end subroutine da_div_profile_tl diff --git a/var/da/da_lightning/da_get_innov_vector_lightning.inc b/var/da/da_lightning/da_get_innov_vector_lightning.inc new file mode 100644 index 0000000000..a67d3ed2af --- /dev/null +++ b/var/da/da_lightning/da_get_innov_vector_lightning.inc @@ -0,0 +1,93 @@ +subroutine da_get_innov_vector_lightning( it, grid, ob, iv) + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: it ! External iteration. + type(domain), intent(in) :: grid ! first guess state. + type(y_type), intent(inout) :: ob ! Observation structure. + type(iv_type), intent(inout) :: iv ! O-B structure. + + integer :: n ! Loop counter. + integer :: i, j, k ! Index dimension. + real :: dx, dxm ! Interpolation weights. + real :: dy, dym ! Interpolation weights. + integer :: num_levs ! obs vertical levels + real :: div(kts:kte) ! Model divergence at ob loc + real :: w(kts:kte) ! Model vertical velocity + + if (trace_use) call da_trace_entry("da_get_innov_vector_lightning") + + if(it>1) then + do n = iv%info(lightning)%n1, iv%info(lightning)%n2 + do k = 1, iv%info(lightning)%levels(n) + if(iv%lightning(n)% w(k)%qc == fails_error_max) iv%lightning(n)% w(k)%qc = 0 + if(iv%lightning(n)%div(k)%qc == fails_error_max) iv%lightning(n)%div(k)%qc = 0 + if(iv%lightning(n)% qv(k)%qc == fails_error_max) iv%lightning(n)% qv(k)%qc = 0 + end do + end do + end if + + do n = iv%info(lightning)%n1, iv%info(lightning)%n2 + num_levs = iv%info(lightning)%levels(n) + + if(num_levs<1) cycle + + div(:) = 0.0 + w(:) = 0.0 + + ! [1.0] Get cross pt. horizontal interpolation weights: + + i = iv%info(lightning)%i(1,n) + dy = iv%info(lightning)%dy(1,n) + dym = iv%info(lightning)%dym(1,n) + j = iv%info(lightning)%j(1,n) + dx = iv%info(lightning)%dx(1,n) + dxm = iv%info(lightning)%dxm(1,n) + + ! [2.0] Calculate vertical profile of divergence and qv at obs pt. + + do k = 1, num_levs + iv % lightning(n) % w(k) % inv = 0.0 + iv % lightning(n) % div(k) % inv = 0.0 + iv % lightning(n) % qv(k) % inv = 0.0 + + if(use_lightning_w) then + if(ob%lightning(n)%w(k) > missing_r .and. iv%lightning(n)%w(k)%qc >= obs_qc_pointer) then + w(k) = dym*(dxm*grid%xb%w(i,j,k)+dx*grid%xb%w(i+1,j,k))+dy*(dxm*grid%xb%w(i,j+1,k)+dx*grid%xb%w(i+1,j+1,k)) + iv%lightning(n)%w(k)%qc = obs_qc_pointer + iv%lightning(n)%w(k)%inv = ob%lightning(n)%w(k) - w(k) + end if + end if + + if(use_lightning_div) then + if(ob%lightning(n)%div(k) > missing_r .and. iv%lightning(n)%div(k)%qc >= obs_qc_pointer) then + iv%lightning(n)%div(k)%qc = obs_qc_pointer + call da_div_profile(grid, iv%info(lightning), n, k, div(k)) + iv%lightning(n)%div(k)%inv = ob%lightning(n)%div(k) - div(k) + end if + end if + + if(use_lightning_qv) then + if(ob%lightning(n)%qv(k) > missing_r .and. iv%lightning(n)%qv(k)%qc >= obs_qc_pointer) then + iv%lightning(n)%qv(k)%inv = ob%lightning(n)%qv(k) - grid%xb%q(i,j,k) + iv%lightning(n)%qv(k)%inv = amax1(0.0, iv%lightning(n)%qv(k)%inv) + end if + end if + + end do + end do + + ! ----------------------------------------------------------------------- + ! [3.0] Perform optional maximum error check: + !----------------------------------------------------------------------- + + if(check_max_iv ) & + call da_check_max_iv_lightning(iv, ob, it) + + if (trace_use) call da_trace_exit("da_get_innov_vector_lightning") + +end subroutine da_get_innov_vector_lightning diff --git a/var/da/da_lightning/da_jo_and_grady_lightning.inc b/var/da/da_lightning/da_jo_and_grady_lightning.inc new file mode 100644 index 0000000000..5741a5714f --- /dev/null +++ b/var/da/da_lightning/da_jo_and_grady_lightning.inc @@ -0,0 +1,66 @@ +subroutine da_jo_and_grady_lightning(iv, re, jo, jo_grad_y) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + type (iv_type), intent(in) :: iv ! Innovation vector. + type (y_type), intent(in) :: re ! Residual vector. + type (y_type), intent(inout) :: jo_grad_y ! Grad_y(Jo) + type (jo_type), intent(inout) :: jo ! Obs cost function. + integer :: n, k + + if (trace_use_dull) call da_trace_entry("da_jo_and_grady_lightning") + + ! defined in da_define_structure.f90 + jo % lightning_w = 0.0 + jo % lightning_div = 0.0 + jo % lightning_qv = 0.0 + + do n = 1, iv%info(lightning)%nlocal + do k = 2, iv%info(lightning)%levels(n) + if(use_lightning_w) then + jo_grad_y%lightning(n)%w(k) = -re%lightning(n)%w(k)/(iv%lightning(n)%w(k)%error * iv%lightning(n)%w(k)%error) + end if + + if(use_lightning_div) then + jo_grad_y%lightning(n)%div(k) = -re%lightning(n)%div(k)/(iv%lightning(n)%div(k)%error * iv%lightning(n)%div(k)%error) + end if + + if(use_lightning_qv) then + jo_grad_y%lightning(n)%qv(k) = -re%lightning(n)%qv(k)/(iv%lightning(n)%qv(k)%error * iv%lightning(n)%qv(k)%error) + end if + end do + + if(iv%info(lightning)%proc_domain(1,n)) then + do k = 2, iv%info(lightning)%levels(n) + + if(use_lightning_w) then + jo%lightning_w = jo%lightning_w-re%lightning(n)%w(k)*jo_grad_y%lightning(n)%w(k) + end if + + if(use_lightning_div) then + jo%lightning_div = jo%lightning_div-re%lightning(n)%div(k) * jo_grad_y%lightning(n)%div(k) + end if + + if(use_lightning_qv) then + jo%lightning_qv = jo%lightning_qv-re%lightning(n)%qv(k)*jo_grad_y%lightning(n)%qv(k) + end if + + end do + end if + + end do + + jo%lightning_w = 0.5 * jo % lightning_w + jo%lightning_div = 0.5 * jo % lightning_div + jo%lightning_qv = 0.5 * jo % lightning_qv + + if (trace_use_dull) call da_trace_exit("da_jo_and_grady_lightning") + +end subroutine da_jo_and_grady_lightning + + diff --git a/var/da/da_lightning/da_lightning.f90 b/var/da/da_lightning/da_lightning.f90 new file mode 100644 index 0000000000..0e33c0eb41 --- /dev/null +++ b/var/da/da_lightning/da_lightning.f90 @@ -0,0 +1,67 @@ +module da_lightning + + use module_domain, only : domain + + use da_control, only : stdout, obs_qc_pointer,max_ob_levels,missing_r, & + v_interp_p, v_interp_h, check_max_iv_print, trace_use, & + missing, max_error_uv, max_error_t, rootproc, & + max_error_p,max_error_q, check_max_iv_unit,check_max_iv, & + max_stheight_diff,missing_data,max_error_bq,max_error_slp, & + max_error_bt, max_error_buv, lightning, qcstat_conv_unit, fails_error_max, & + use_lightning_w, use_lightning_qv, use_lightning_div, & + fg_format,fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional,fg_format_wrf_arw_global,& + fg_format_kma_global,max_error_lda_w,max_error_lda_qv, max_error_lda_div, & + far_below_model_surface,kms,kme,kts,kte, trace_use_dull,filename_len,& + myproc, analysis_date, num_procs , ierr, comm + + use da_control, only : its, ite, jts, jte, ids, ide, jds, jde, ims, ime, jms, jme + use da_control, only : cloudbase_calc_opt + use da_define_structures, only : maxmin_type, iv_type, y_type, jo_type, & + bad_data_type, x_type, number_type, bad_data_type, & + infa_type, field_type + use da_interpolation, only : da_to_zk, da_interp_lin_3d,da_interp_lin_3d_adj + use da_par_util, only :da_proc_stats_combine, da_patch_to_global + use da_par_util1, only : da_proc_sum_int + use da_statistics, only : da_stats_calculate + use da_tools, only : da_max_error_qc, da_residual, map_info, da_llxy_wrf, da_llxy_default, da_convert_zk + use da_tracing, only : da_trace_entry, da_trace_exit + use da_reporting, only : da_error, da_warning, da_message, message + use da_tools_serial, only : da_get_unit, da_free_unit + + ! The "stats_lightning_type" is ONLY used locally in da_lightning: + + type residual_lightning1_type + real :: w + real :: div + real :: qv + end type residual_lightning1_type + + type maxmin_lightning_stats_type + type (maxmin_type) :: w ! vertical velocity + type (maxmin_type) :: div ! divgerence + type (maxmin_type) :: qv ! water vapor + end type maxmin_lightning_stats_type + + type stats_lightning_type + type (maxmin_lightning_stats_type) :: maximum, minimum + type (residual_lightning1_type) :: average, rms_err + end type stats_lightning_type + +contains + +#include "da_ao_stats_lightning.inc" +#include "da_jo_and_grady_lightning.inc" +#include "da_residual_lightning.inc" +#include "da_oi_stats_lightning.inc" +#include "da_print_stats_lightning.inc" +#include "da_transform_xtoy_lightning.inc" +#include "da_transform_xtoy_lightning_adj.inc" +#include "da_check_max_iv_lightning.inc" +#include "da_get_innov_vector_lightning.inc" +#include "da_calculate_grady_lightning.inc" +#include "da_div_profile.inc" +#include "da_div_profile_tl.inc" +#include "da_div_profile_adj.inc" + +end module da_lightning + diff --git a/var/da/da_lightning/da_oi_stats_lightning.inc b/var/da/da_lightning/da_oi_stats_lightning.inc new file mode 100644 index 0000000000..9ee917b187 --- /dev/null +++ b/var/da/da_lightning/da_oi_stats_lightning.inc @@ -0,0 +1,98 @@ +subroutine da_oi_stats_lightning (stats_unit, iv) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + integer, intent (in) :: stats_unit ! Output unit for stats. + type (iv_type), intent (in) :: iv ! OI + + type (stats_lightning_type) :: stats + integer :: nw, nqv, ndiv + integer :: n, k + + if (trace_use_dull) call da_trace_entry("da_oi_stats_lightning") + + nw = 0 + ndiv = 0 + nqv = 0 + + stats%maximum%w = maxmin_type(missing_r, 0, 0) + stats%minimum%w = maxmin_type(-missing_r, 0, 0) + stats%maximum%div = maxmin_type(missing_r, 0, 0) + stats%minimum%div = maxmin_type(-missing_r, 0, 0) + stats%maximum%qv = maxmin_type(missing_r, 0, 0) + stats%minimum%qv = maxmin_type(-missing_r, 0, 0) + + stats%average = residual_lightning1_type(0.0, 0.0, 0.0) + stats%rms_err = stats%average + + do n = 1, iv%info(lightning)%nlocal + if(iv%info(lightning)%proc_domain(1,n)) then + do k = 1, iv%info(lightning)%levels(n) + if(use_lightning_w) then + call da_stats_calculate(iv%info(lightning)%obs_global_index(n), & + k, iv%lightning(n)%w(k)%qc, & + iv%lightning(n)%w(k)%inv, nw, & + stats%minimum%w, stats%maximum%w, & + stats%average%w, stats%rms_err%w) + end if + + if(use_lightning_div) then + call da_stats_calculate(iv%info(lightning)%obs_global_index(n), & + k, iv%lightning(n)%div(k)%qc, & + iv%lightning(n)%div(k)%inv, ndiv, & + stats%minimum%div, stats%maximum%div, & + stats%average%div, stats%rms_err%div) + end if + + if(use_lightning_qv) then + call da_stats_calculate(iv%info(lightning)%obs_global_index(n), & + k, iv%lightning(n)%qv(k)%qc, & + iv%lightning(n)%qv(k)%inv, nqv, & + stats%minimum%qv, stats%maximum%qv, & + stats%average%qv, stats%rms_err%qv) + end if + + end do + end if + end do + + ! Do inter-processor communication to gather statistics. + if (use_lightning_w) then + call da_proc_sum_int (nw) + call da_proc_stats_combine(stats%average%w, stats%rms_err%w, & + stats%minimum%w%value, stats%maximum%w%value, & + stats%minimum%w%n, stats%maximum%w%n, & + stats%minimum%w%l, stats%maximum%w%l) + end if + + if (use_lightning_div) then + call da_proc_sum_int (ndiv) + call da_proc_stats_combine(stats%average%div, stats%rms_err%div, & + stats%minimum%div%value, stats%maximum%div%value, & + stats%minimum%div%n, stats%maximum%div%n, & + stats%minimum%div%l, stats%maximum%div%l) + end if + + if (use_lightning_qv) then + call da_proc_sum_int (nqv) + call da_proc_stats_combine(stats%average%qv, stats%rms_err%qv, & + stats%minimum%qv%value, stats%maximum%qv%value, & + stats%minimum%qv%n, stats%maximum%qv%n, & + stats%minimum%qv%l, stats%maximum%qv%l) + end if + + if (rootproc) then + if ( nw /= 0 .or. ndiv /= 0 .or. nqv /= 0 ) then + write(unit=stats_unit, fmt='(/a/)') ' Diagnostics of OI for lightning' + call da_print_stats_lightning(stats_unit, nw, ndiv, nqv, stats) + end if + end if + + if (trace_use_dull) call da_trace_exit("da_oi_stats_lightning") + +end subroutine da_oi_stats_lightning diff --git a/var/da/da_lightning/da_print_stats_lightning.inc b/var/da/da_lightning/da_print_stats_lightning.inc new file mode 100644 index 0000000000..d6d96fc2c6 --- /dev/null +++ b/var/da/da_lightning/da_print_stats_lightning.inc @@ -0,0 +1,41 @@ +subroutine da_print_stats_lightning(stats_unit, nw, ndiv, nqv, lightning) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: stats_unit + integer, intent(inout) :: nw, ndiv, nqv + type (stats_lightning_type), intent(in):: lightning + + if (trace_use_dull) call da_trace_entry("da_print_stats_lightning") + + write(unit=stats_unit, fmt='(a/)') & + ' var w (m/s) n k div (1/s) n k qv (kg/kg) n k' + + write(unit=stats_unit, fmt='(a,(i16,2i31))') & + ' Number: ', nw, ndiv, nqv + + if (nw < 1) nw = 1 + if (ndiv < 1) ndiv = 1 + if (nqv < 1) nqv = 1 + + write(unit=stats_unit, fmt='((a,f12.4,i9,i5, 2(f17.4,i9,i5)))') & + ' Minimum(n,k): ', lightning%minimum%w, lightning%minimum%div, lightning%minimum%qv + write(unit=stats_unit, fmt='((a,f12.4,i9,i5, 2(f17.4,i9,i5)))') & + ' Maximum(n,k): ', lightning%maximum%w, lightning%maximum%div, lightning%maximum%qv + write(unit=stats_unit, fmt='((a,3(f12.4,19x)))') & + ' Average : ', lightning%average%w/real(nw), & + lightning%average%div/real(ndiv), & + lightning%average%qv/real(nqv) + write(unit=stats_unit, fmt='((a,3(f12.4,19x)))') & + ' RMSE : ', sqrt(lightning%rms_err%w/real(nw)), & + sqrt(lightning%rms_err%div/real(ndiv)), & + sqrt(lightning%rms_err%qv/real(nqv)) + + if (trace_use_dull) call da_trace_exit("da_print_stats_lightning") + +end subroutine da_print_stats_lightning diff --git a/var/da/da_lightning/da_residual_lightning.inc b/var/da/da_lightning/da_residual_lightning.inc new file mode 100644 index 0000000000..84c1feb7f4 --- /dev/null +++ b/var/da/da_lightning/da_residual_lightning.inc @@ -0,0 +1,54 @@ +subroutine da_residual_lightning(iv, y, re,np_missing, np_bad_data,np_obs_used, np_available) + + !----------------------------------------------------------------------- + ! Purpose: Calculate residuals for lightning obs + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + type (iv_type), intent(in) :: iv ! Innovation vector (O-B). + type (y_type) , intent(in) :: y ! y = H (xa) + type (y_type) , intent(inout) :: re ! Residual vector (O-A). + + integer , intent(inout) :: np_available + integer , intent(inout) :: np_obs_used + integer , intent(inout) :: np_missing + integer , intent(inout) :: np_bad_data + + type (bad_data_type) :: n_obs_bad + integer :: n, k + + if (trace_use_dull) call da_trace_entry("da_residual_lightning") + + n_obs_bad%w%num = number_type(0, 0, 0) + n_obs_bad%q%num = number_type(0, 0, 0) + n_obs_bad%div%num = number_type(0, 0, 0) + + do n = 1, iv%info(lightning)%nlocal + do k = 1, iv%info(lightning)%levels(n) + + if(use_lightning_w) then + np_available = np_available + 1 + re%lightning(n)%w(k) = da_residual(n, k, y%lightning(n)%w(k), iv%lightning(n)%w(k), n_obs_bad % w) + end if + + if(use_lightning_div) then + np_available = np_available + 1 + re%lightning(n)%div(k) = da_residual(n, k, y%lightning(n)%div(k), iv%lightning(n)%div(k), n_obs_bad % div) + end if + + if(use_lightning_qv) then + np_available = np_available + 1 + re%lightning(n)%qv(k) = da_residual(n, k, y%lightning(n)%qv(k), iv%lightning(n)%qv(k), n_obs_bad % q) + end if + end do + end do + + np_missing = np_missing + n_obs_bad%w%num%miss + n_obs_bad%div%num%miss + n_obs_bad%q%num%miss + np_bad_data = np_bad_data + n_obs_bad%w%num%bad + n_obs_bad%div%num%bad + n_obs_bad%q%num%bad + np_obs_used = np_obs_used + n_obs_bad%w%num%use + n_obs_bad%div%num%use + n_obs_bad%q%num%use + + if (trace_use_dull) call da_trace_exit("da_residual_lightning") + +end subroutine da_residual_lightning diff --git a/var/da/da_lightning/da_transform_xtoy_lightning.inc b/var/da/da_lightning/da_transform_xtoy_lightning.inc new file mode 100644 index 0000000000..902b1e5819 --- /dev/null +++ b/var/da/da_lightning/da_transform_xtoy_lightning.inc @@ -0,0 +1,75 @@ +subroutine da_transform_xtoy_lightning (grid, iv, y) + + !----------------------------------------------------------------------- + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + type (domain), intent(in) :: grid + type (iv_type), intent(in) :: iv ! Innovation vector (O-B). + type (y_type), intent(inout) :: y ! y = h (grid%xa) + + integer :: n ! Loop counter. + integer :: i, j, k ! Index dimension. + real :: dx, dxm ! + real :: dy, dym ! + integer :: num_levs ! obs vertical levels + + real :: div(kts:kte) !Model divergence at ob loc + real :: ave_div(kts:kte) !Model averaged divergence at ob loc + real :: model_q(kts:kte) !Model Q at ob loc + real :: model_t(kts:kte) !Model T at ob loc + + real :: TGL_div(kts:kte) + real :: TGL_model_q(kts:kte) + + if (trace_use_dull) call da_trace_entry("da_transform_xtoy_lightning") + + do n = iv%info(lightning)%n1, iv%info(lightning)%n2 + + num_levs = iv%info(lightning)%levels(n) + + ! [1.0] Get horizontal interpolation weights: + + i = iv%info(lightning)%i(1,n) + dy = iv%info(lightning)%dy(1,n) + dym = iv%info(lightning)%dym(1,n) + j = iv%info(lightning)%j(1,n) + dx = iv%info(lightning)%dx(1,n) + dxm = iv%info(lightning)%dxm(1,n) + + TGL_div(:) = 0.0 + do k= 1, num_levs + + if(use_lightning_w) then + if(iv%lightning(n)%w(k)%qc == missing_data) then + y%lightning(n)%w(k) = 0.0 + else + y%lightning(n)%w(k) = grid%xa%w(i,j,k) + end if + end if + + if(use_lightning_div) then + if(iv%lightning(n)%div(k)%qc == missing_data) then + y%lightning(n)%div(k) = 0.0 + else + call da_div_profile_tl(grid, iv%info(lightning), n, k, TGL_div(k)) ! divergence profile + y%lightning(n)%div(k) = TGL_div(k) + end if + end if + + if(use_lightning_qv) then + if(iv%lightning(n)%qv(k)%qc == missing_data) then + y%lightning(n)%qv(k) = 0.0 + else + y%lightning(n)%qv(k) = grid%xa%q(i,j,k) + y%lightning(n)%qv(k) = y%lightning(n)%qv(k) + (17.67*243.5/(grid%xb%t(i,j,k)+243.5)**2.0)*grid%xb%q(i,j,k)*grid%xa%t(i,j,k) + end if + end if + + end do + end do + if (trace_use_dull) call da_trace_exit("da_transform_xtoy_lightning") + +end subroutine da_transform_xtoy_lightning diff --git a/var/da/da_lightning/da_transform_xtoy_lightning_adj.inc b/var/da/da_lightning/da_transform_xtoy_lightning_adj.inc new file mode 100644 index 0000000000..59e4b466c3 --- /dev/null +++ b/var/da/da_lightning/da_transform_xtoy_lightning_adj.inc @@ -0,0 +1,71 @@ +subroutine da_transform_xtoy_lightning_adj(grid, iv, jo_grad_y, jo_grad_x) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + type (domain), intent(in) :: grid + type (iv_type), intent(in) :: iv ! obs. inc vector (o-b). + type (y_type) , intent(inout) :: jo_grad_y ! grad_y(jo) + type (x_type) , intent(inout) :: jo_grad_x ! grad_x(jo) + + integer :: n, k ! Loop counter. + integer :: num_levs ! obs vertical levels + + integer :: i, j ! Index dimension. + real :: dx, dxm ! + real :: dy, dym ! + + real :: div(kts:kte) !Model divergence at ob loc + real :: ave_div(kts:kte) !Model averaged divergence at ob loc + real :: model_q(kts:kte) !Model RH at ob loc + real :: model_t(kts:kte) !Model T at ob loc + + real :: ADJ_div(kts:kte) + + if (trace_use_dull) call da_trace_entry("da_transform_xtoy_lightning_adj") + + do n = iv%info(lightning)%n1, iv%info(lightning)%n2 + num_levs = iv%info(lightning)%levels(n) + + ! [1.0] Get horizontal interpolation weights: + + i = iv%info(lightning)%i(1,n) + dy = iv%info(lightning)%dy(1,n) + dym = iv%info(lightning)%dym(1,n) + j = iv%info(lightning)%j(1,n) + dx = iv%info(lightning)%dx(1,n) + dxm = iv%info(lightning)%dxm(1,n) + + ADJ_div(:) = 0.0 + + do k = 1, num_levs + if(use_lightning_w) then + if(iv % lightning(n)%w(k)%qc /= missing_data) then + jo_grad_x%w(i,j,k) = jo_grad_x%w(i,j,k) + jo_grad_y%lightning(n)%w(k) + end if + end if + + if(use_lightning_div) then + if(iv % lightning(n)%div(k)%qc /= missing_data) then + call da_div_profile_adj(grid, jo_grad_x, iv%info(lightning), n, k, jo_grad_y%lightning(n)%div(k)) + end if + end if + + if(use_lightning_qv) then + if(iv % lightning(n)%qv(k)%qc /= missing_data) then + jo_grad_x%q(i,j,k) = jo_grad_x%q(i,j,k) + jo_grad_y%lightning(n)%qv(k) + jo_grad_x%t(i,j,k) = jo_grad_x%t(i,j,k) + (17.67*243.5/(grid%xb%t(i,j,k)+243.5)**2.0)*grid%xb%q(i,j,k)*jo_grad_y%lightning(n)%qv(k) + end if + end if + + end do + + end do + + if (trace_use_dull) call da_trace_exit("da_transform_xtoy_lightning_adj") + +end subroutine da_transform_xtoy_lightning_adj diff --git a/var/da/da_main/da_wrfvar_top.f90 b/var/da/da_main/da_wrfvar_top.f90 index 6205ab539d..240ceb5be0 100644 --- a/var/da/da_main/da_wrfvar_top.f90 +++ b/var/da/da_main/da_wrfvar_top.f90 @@ -121,6 +121,7 @@ module da_wrfvar_top use da_qscat, only : da_oi_stats_qscat use da_mtgirs, only : da_oi_stats_mtgirs use da_radar, only : da_oi_stats_radar, da_write_oa_radar_ascii + use da_lightning, only : da_oi_stats_lightning use da_satem, only : da_oi_stats_satem use da_ships, only : da_oi_stats_ships use da_sound, only : da_oi_stats_sound, da_oi_stats_sonde_sfc diff --git a/var/da/da_minimisation/da_calculate_grady.inc b/var/da/da_minimisation/da_calculate_grady.inc index f798d51e36..66e205a3e3 100644 --- a/var/da/da_minimisation/da_calculate_grady.inc +++ b/var/da/da_minimisation/da_calculate_grady.inc @@ -39,6 +39,7 @@ subroutine da_calculate_grady(iv, re, jo_grad_y) if (iv%info(bogus)%nlocal > 0) call da_calculate_grady_bogus (iv, re, jo_grad_y) if (iv%info(qscat)%nlocal > 0) call da_calculate_grady_qscat (iv, re, jo_grad_y) if (iv%info(radar)%nlocal > 0) call da_calculate_grady_radar (iv, re, jo_grad_y) + if (iv%info(lightning)%nlocal > 0) call da_calculate_grady_lightning(iv, re, jo_grad_y) if (iv%info(mtgirs)%nlocal > 0) call da_calculate_grady_mtgirs (iv, re, jo_grad_y) if (iv%info(tamdar)%nlocal > 0) call da_calculate_grady_tamdar (iv, re, jo_grad_y) if (iv%info(tamdar_sfc)%nlocal> 0) call da_calculate_grady_tamdar_sfc(iv, re, jo_grad_y) diff --git a/var/da/da_minimisation/da_calculate_residual.inc b/var/da/da_minimisation/da_calculate_residual.inc index 7351eb87d1..121bcce6ac 100644 --- a/var/da/da_minimisation/da_calculate_residual.inc +++ b/var/da/da_minimisation/da_calculate_residual.inc @@ -95,6 +95,9 @@ subroutine da_calculate_residual(iv, y, re) if (iv%info(radar)%nlocal > 0) & call da_residual_radar(iv, y, re, np_missing, np_bad_data, np_obs_used, np_available) + if (iv%info(lightning)%nlocal > 0) & + call da_residual_lightning(iv, y, re, np_missing, np_bad_data, np_obs_used, np_available) + if (iv%info(profiler)%nlocal > 0) & call da_residual_profiler(iv, y, re, np_missing, np_bad_data, np_obs_used, np_available) diff --git a/var/da/da_minimisation/da_get_innov_vector.inc b/var/da/da_minimisation/da_get_innov_vector.inc index 6ecc4c1aac..142b78b1ad 100644 --- a/var/da/da_minimisation/da_get_innov_vector.inc +++ b/var/da/da_minimisation/da_get_innov_vector.inc @@ -150,6 +150,8 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) call da_get_innov_vector_satem (it, num_qcstat_conv,grid, ob, iv) if (iv%info(radar)%nlocal >= 0 .and. use_radarobs) & call da_get_innov_vector_radar (it, grid, ob, iv) + if (iv%info(lightning)%nlocal > 0) & + call da_get_innov_vector_lightning (it, grid, ob, iv) if (iv%info(qscat)%nlocal > 0) & call da_get_innov_vector_qscat (it, num_qcstat_conv,grid, ob, iv) if (iv%info(profiler)%nlocal > 0) & diff --git a/var/da/da_minimisation/da_get_var_diagnostics.inc b/var/da/da_minimisation/da_get_var_diagnostics.inc index dc135c8c16..aba293bcf1 100644 --- a/var/da/da_minimisation/da_get_var_diagnostics.inc +++ b/var/da/da_minimisation/da_get_var_diagnostics.inc @@ -13,7 +13,7 @@ subroutine da_get_var_diagnostics(it, iv, j) integer :: num_stats_tot integer :: i,k real :: jo_radiance - real :: temp(79) + real :: temp(82) if (trace_use) call da_trace_entry("da_get_var_diagnostics") @@ -103,7 +103,10 @@ subroutine da_get_var_diagnostics(it, iv, j) temp(77) = j % jo % rain_r !temp(78) is j % jo % airep_q listed up with other airep variables temp(79) = j % jo % gpseph_eph - + temp(80) = j % jo % lightning_w + temp(81) = j % jo % lightning_div + temp(82) = j % jo % lightning_qv + call da_proc_sum_real(temp(:)) j % jo % synop_u = temp(1) @@ -188,6 +191,10 @@ subroutine da_get_var_diagnostics(it, iv, j) j % jo % rain_r = temp(77) j % jo % gpseph_eph = temp(79) + j % jo % lightning_w = temp(80) + j % jo % lightning_div = temp(81) + j % jo % lightning_qv = temp(82) + if (use_rad) then jo_radiance = 0.0 do i = 1, iv%num_inst ! loop for sensor @@ -470,6 +477,14 @@ subroutine da_get_var_diagnostics(it, iv, j) j % jo % airsr_q, iv % airsr_ef_q, & 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 end if + if (iv%info(lightning)%ntotal > 0) then + write(unit=jo_unit,fmt='(a30,2i8,10f15.5)')'lightning obs, Jo(actual) = ', & + iv%info(lightning)%ntotal, iv%nstats(lightning), & + j % jo % lightning_w, iv % lightning_ef_w, & + j % jo % lightning_div, iv % lightning_ef_div, & + j % jo % lightning_qv, iv % lightning_ef_qv, & + 0.0, 1.0, 0.0, 1.0 + end if do i = 1, iv%num_inst ! loop for sensor do k = 1, iv%instid(i)%nchan if (j % jo % rad(i) % num_ichan(k) > 0) then diff --git a/var/da/da_minimisation/da_jo_and_grady.inc b/var/da/da_minimisation/da_jo_and_grady.inc index 4b5a213813..bce6bf3c60 100644 --- a/var/da/da_minimisation/da_jo_and_grady.inc +++ b/var/da/da_minimisation/da_jo_and_grady.inc @@ -17,7 +17,7 @@ subroutine da_jo_and_grady(iv, re, jot, jo, jo_grad_y) jo_airep, jo_pilot, jo_satem, & jo_metar, jo_ships, jo_gpspw, & jo_ssmi_tb, jo_ssmi_rv, jo_ssmt1, jo_ssmt2, & - jo_pseudo, jo_qscat, jo_buoy, & + jo_pseudo, jo_qscat, jo_buoy, jo_lightning, & jo_profiler, jo_radar, jo_gpsref, jo_gpseph, jo_bogus, jo_rain, & jo_radiance, jo_airsr, jo_mtgirs, jo_tamdar, jo_tamdar_sfc #if (WRF_CHEM == 1) @@ -416,6 +416,23 @@ subroutine da_jo_and_grady(iv, re, jot, jo, jo_grad_y) jo_radar = 0.0 end if + if (iv%info(lightning)%nlocal > 0) then + call da_jo_and_grady_lightning(iv, re, jo, jo_grad_y) + jo_lightning = jo%lightning_w + jo%lightning_div + jo%lightning_qv + if (print_detail_grad) then + write(unit=stdout, fmt='(a, e24.12)') & + ' jo_lightning ', jo_lightning, & + ' jo%lightning_w ', jo%lightning_w, & + ' jo%lightning_div', jo%lightning_div, & + ' jo%lightning_qv ', jo%lightning_qv + end if + else + jo % lightning_w = 0.0 + jo % lightning_div = 0.0 + jo % lightning_qv = 0.0 + jo_lightning = 0.0 + end if + if (iv%info(rain)%nlocal > 0) then call da_jo_and_grady_rain(iv, re, jo, jo_grad_y) jo_rain = jo%rain_r @@ -593,7 +610,7 @@ subroutine da_jo_and_grady(iv, re, jot, jo, jo_grad_y) #if (WRF_CHEM == 1) jo_chemic_surf + & #endif - jo_tamdar + jo_tamdar_sfc + jo_rain + jo_tamdar + jo_tamdar_sfc + jo_rain + jo_lightning jot = jo%total @@ -633,7 +650,8 @@ subroutine da_jo_and_grady(iv, re, jot, jo, jo_grad_y) #if (WRF_CHEM == 1) ' jo_chemic_surf ', jo_chemic_surf, & #endif - ' jo_rain ', jo_rain + ' jo_rain ', jo_rain, & + ' jo_lightning ', jo_lightning end if diff --git a/var/da/da_minimisation/da_minimisation.f90 b/var/da/da_minimisation/da_minimisation.f90 index 56355d1992..519066af0b 100644 --- a/var/da/da_minimisation/da_minimisation.f90 +++ b/var/da/da_minimisation/da_minimisation.f90 @@ -54,10 +54,10 @@ module da_minimisation chemic_surf, chemicda_opt, & #endif sound, mtgirs, sonde_sfc, synop, profiler, gpsref, gpseph, gpspw, polaramv, geoamv, ships, metar, & - satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep,tamdar, tamdar_sfc, rain, & + satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep,tamdar, tamdar_sfc, rain, lightning, & bogus, buoy, qscat,pseudo, radiance, monitor_on, max_ext_its, use_rttov_kmatrix,& use_crtm_kmatrix,precondition_cg, precondition_factor, use_varbc, varbc_factor, & - biasprep, qc_rad, num_procs, myproc, use_gpspwobs, use_rainobs, use_gpsztdobs, & + biasprep, qc_rad, num_procs, myproc, use_gpspwobs, use_rainobs, use_gpsztdobs, use_lightningobs, & use_radar_rf, radar_rf_opt,radar_rf_rscl,radar_rv_rscl,use_radar_rhv,use_radar_rqv,pseudo_var, num_pseudo, & num_ob_indexes, num_ob_vars, npres_print, pptop, ppbot, qcstat_conv_unit, gas_constant, & orthonorm_gradient, its, ite, jts, jte, kts, kte, ids, ide, jds, jde, kds, kde, cp, & @@ -140,6 +140,10 @@ module da_minimisation use da_radar, only : da_calculate_grady_radar, da_ao_stats_radar, & da_oi_stats_radar, da_get_innov_vector_radar, da_residual_radar, & da_jo_and_grady_radar + + use da_lightning, only : da_calculate_grady_lightning, da_ao_stats_lightning, & + da_oi_stats_lightning, da_get_innov_vector_lightning, da_residual_lightning, & + da_jo_and_grady_lightning use da_rain, only : da_calculate_grady_rain, da_ao_stats_rain, & da_oi_stats_rain, da_get_innov_vector_rain, da_residual_rain, & diff --git a/var/da/da_minimisation/da_write_diagnostics.inc b/var/da/da_minimisation/da_write_diagnostics.inc index 55f33a0426..18a1998f11 100644 --- a/var/da/da_minimisation/da_write_diagnostics.inc +++ b/var/da/da_minimisation/da_write_diagnostics.inc @@ -58,6 +58,7 @@ use da_control, only : stats_unit2 if (iv%info(profiler)%ntotal > 0) call da_oi_stats_profiler (stats_unit, iv, ob) if (iv%info(buoy)%ntotal > 0) call da_oi_stats_buoy (stats_unit, iv, ob) if (iv%info(radar)%ntotal > 0) call da_oi_stats_radar (stats_unit, iv) + if (iv%info(lightning)%ntotal> 0) call da_oi_stats_lightning(stats_unit, iv) if (iv%info(bogus)%ntotal > 0) call da_oi_stats_bogus (stats_unit, iv) if (iv%info(airsr)%ntotal > 0) call da_oi_stats_airsr (stats_unit, iv) if (iv%info(rain)%ntotal > 0) call da_oi_stats_rain (stats_unit, iv) @@ -101,6 +102,7 @@ if (.not. anal_type_verify) then if (iv%info(profiler)%ntotal > 0) call da_ao_stats_profiler (stats_unit, iv, re, ob) if (iv%info(buoy)%ntotal > 0) call da_ao_stats_buoy (stats_unit, iv, re, ob) if (iv%info(radar)%ntotal > 0) call da_ao_stats_radar (stats_unit, iv, re) + if (iv%info(lightning)%ntotal> 0) call da_ao_stats_lightning(stats_unit, iv, re) if (iv%info(bogus)%ntotal > 0) call da_ao_stats_bogus (stats_unit, iv, re) if (iv%info(airsr)%ntotal > 0) call da_ao_stats_airsr (stats_unit, iv, re) if (iv%info(rain)%ntotal > 0) call da_ao_stats_rain (stats_unit, iv, re) diff --git a/var/da/da_monitor/da_rad_diags.f90 b/var/da/da_monitor/da_rad_diags.f90 index af42a488ff..6d2db8f686 100644 --- a/var/da/da_monitor/da_rad_diags.f90 +++ b/var/da/da_monitor/da_rad_diags.f90 @@ -42,7 +42,7 @@ program da_rad_diags integer :: ncid, dimid, varid integer, dimension(3) :: ishape, istart, icount ! - logical :: amsr2 + logical :: amsr2, abi logical :: isfile, prf_found, jac_found integer, parameter :: datelen1 = 10 integer, parameter :: datelen2 = 19 @@ -62,9 +62,9 @@ program da_rad_diags real*4, dimension(:), allocatable :: smois, tslb, snowh, vegfra, clwp, cloud_frac real*4, dimension(:), allocatable :: cip ! cloud-ice path integer, dimension(:), allocatable :: cloudflag ! cloudflag from L2 AHI - integer, dimension(:,:), allocatable :: tb_qc + integer, dimension(:,:), allocatable :: tb_qc, cloud_flag real*4, dimension(:,:), allocatable :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac - real*4, dimension(:,:), allocatable :: tb_bak_clr ! clear-sky brightness temp + real*4, dimension(:,:), allocatable :: cloud_mod, cloud_obs, tb_bak_clr ! clear-sky brightness temp real*4, dimension(:,:), allocatable :: weightfunc_peak ! peak of weighting function real*4, dimension(:,:), allocatable :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water real*4, dimension(:,:), allocatable :: prf_ice, prf_rain, prf_snow, prf_grau, prf_hail @@ -139,6 +139,7 @@ program da_rad_diags write(0,*) trim(instid(iinst)) amsr2 = index(instid(iinst),'amsr2') > 0 + abi = index(instid(iinst),'abi') > 0 nerr = 0 total_npixel = 0 @@ -263,6 +264,12 @@ program da_rad_diags allocate ( tb_oma(1:nchan,1:total_npixel) ) allocate ( tb_err(1:nchan,1:total_npixel) ) allocate ( tb_qc(1:nchan,1:total_npixel) ) + if ( abi ) then + allocate ( cloud_mod(1:nchan,1:total_npixel) ) + allocate ( cloud_obs(1:nchan,1:total_npixel) ) + allocate ( cloud_flag(1:nchan,1:total_npixel)) + cloud_flag = 0 + end if allocate ( ems(1:nchan,1:total_npixel) ) if ( jac_found ) then allocate ( ems_jac(1:nchan,1:total_npixel) ) @@ -333,6 +340,11 @@ program da_rad_diags tb_inv = missing_r tb_oma = missing_r tb_err = missing_r + if ( abi ) then + cloud_mod = missing_r + cloud_obs = missing_r + end if + ncname = 'diags_'//trim(instid(iinst))//"_"//datestr1(itime)//'.nc' ios = NF_CREATE(trim(ncname), NF_NETCDF4, ncid) ! Change to output netcdf4 files !ios = NF_CREATE(trim(ncname), NF_CLOBBER, ncid) ! NF_CLOBBER specifies the default behavior of @@ -392,7 +404,15 @@ program da_rad_diags read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel) read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! QC read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) tb_qc(:,ipixel) - read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf + if ( abi .and. buf(1:4) == "CMOD" ) then ! read cloud_mod, cloud_obs, cloud_flag for abi + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_mod(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! CMOD + read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) cloud_obs(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! COBS + read(unit=iunit(iproc),fmt='(10i11)',iostat=ios ) cloud_flag(:,ipixel) + read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf ! cloud_flag + end if if ( buf(1:4) == "INFO" ) then backspace(iunit(iproc)) cycle npixel_loop @@ -523,6 +543,13 @@ program da_rad_diags end if ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid) ios = NF_DEF_VAR(ncid, 'tb_qc', NF_INT, 2, ishape(1:2), varid) + if ( abi ) then + ios = NF_DEF_VAR(ncid, 'cloud_mod', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'cloud_obs', NF_FLOAT, 2, ishape(1:2), varid) + ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r) + ios = NF_DEF_VAR(ncid, 'cloud_flag', NF_INT, 2, ishape(1:2), varid) + end if ! ! define 2-D array with dimensions nlev * total_npixel ! @@ -669,6 +696,14 @@ program da_rad_diags ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err) ios = NF_INQ_VARID (ncid, 'tb_qc', varid) ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), tb_qc) + if ( abi ) then + ios = NF_INQ_VARID (ncid, 'cloud_mod', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_mod) + ios = NF_INQ_VARID (ncid, 'cloud_obs', varid) + ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), cloud_obs) + ios = NF_INQ_VARID (ncid, 'cloud_flag', varid) + ios = NF_PUT_VARA_INT(ncid, varid, istart(1:2), icount(1:2), cloud_flag) + end if ! ! output 2-D array with dimensions nlev * total_npixel ! @@ -890,6 +925,11 @@ program da_rad_diags deallocate ( tb_bak_clr ) deallocate ( weightfunc_peak ) deallocate ( tb_inv ) + if ( abi ) then + deallocate ( cloud_mod ) + deallocate ( cloud_obs ) + deallocate ( cloud_flag ) + end if deallocate ( tb_oma ) deallocate ( ems ) if ( jac_found ) deallocate ( ems_jac ) diff --git a/var/da/da_obs/da_fill_obs_structures.inc b/var/da/da_obs/da_fill_obs_structures.inc index 48a877b889..7050c7a855 100644 --- a/var/da/da_obs/da_fill_obs_structures.inc +++ b/var/da/da_obs/da_fill_obs_structures.inc @@ -16,9 +16,20 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) real :: geometric_h, geopotential_h integer :: i,j logical :: outside + logical :: uvq_direct_local if (trace_use) call da_trace_entry("da_fill_obs_structures") + !--------------------------------------------------------------------------- + ! Initialise uvq_direct_local + !--------------------------------------------------------------------------- + + if (.not. present(uvq_direct)) then + uvq_direct_local = .false. + else + uvq_direct_local = uvq_direct + end if + !--------------------------------------------------------------------------- ! Initialise obs error factors (which will be overwritten in use_obs_errfac) !--------------------------------------------------------------------------- @@ -93,6 +104,10 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) iv % radar_ef_rv = 1.0 iv % radar_ef_rf = 1.0 + iv % lightning_ef_w = 1.0 + iv % lightning_ef_div = 1.0 + iv % lightning_ef_qv = 1.0 + iv % rain_ef_r = 1.0 iv % bogus_ef_u = 1.0 @@ -143,8 +158,8 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) if ( q_error_options == 1 ) then ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%synop(n)%q%error ! q error is rh at this stage! + if (.not. uvq_direct_local) then + rh_error = iv%synop(n)%q%error ! q error is rh at this stage! ! if((ob % synop(n) % p > iv%ptop) .AND. & ! (ob % synop(n) % t > 100.0) .AND. & @@ -152,12 +167,12 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! (iv % synop(n) % p % qc >= obs_qc_pointer) .and. & ! (iv % synop(n) % t % qc >= obs_qc_pointer) .and. & ! (iv % synop(n) % q % qc >= obs_qc_pointer)) then - call da_get_q_error(ob % synop(n) % p, & + call da_get_q_error(ob % synop(n) % p, & ob % synop(n) % t, & ob % synop(n) % q, & iv % synop(n) % t % error, & rh_error, iv % synop(n) % q % error) - if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data + if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data ! end if end if @@ -177,16 +192,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%metar(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % metar(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%metar(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % metar(n) % p % inv, & ob % metar(n) % t, & ob % metar(n) % q, & iv % metar(n) % t % error, & rh_error, q_error) - iv % metar(n) % q % error = q_error - if (iv%metar(n)% q % error == missing_r) & - iv%metar(n)% q % qc = missing_data + iv % metar(n) % q % error = q_error + if (iv%metar(n)% q % error == missing_r) & + iv%metar(n)% q % qc = missing_data end if end do end if @@ -203,16 +218,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%ships(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % ships(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%ships(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % ships(n) % p % inv, & ob % ships(n) % t, & ob % ships(n) % q, & iv % ships(n) % t % error, & rh_error, q_error) - iv % ships(n) % q % error = q_error + iv % ships(n) % q % error = q_error - if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data + if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data end if end do @@ -297,7 +312,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then + if (.not. uvq_direct_local) then rh_error = iv%sound(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % sound(n) % p(k), & ob % sound(n) % t(k), & @@ -306,8 +321,8 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) rh_error, q_error) iv % sound(n) % q(k) % error = q_error - if (iv%sound(n)% q(k) % error == missing_r) & - iv%sound(n)% q(k) % qc = missing_data + if (iv%sound(n)% q(k) % error == missing_r) & + iv%sound(n)% q(k) % qc = missing_data end if end do end do @@ -323,15 +338,15 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % sonde_sfc(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % sonde_sfc(n) % p % inv, & ob % sonde_sfc(n) % t, & ob % sonde_sfc(n) % q, & iv % sonde_sfc(n) % t % error, & rh_error, iv % sonde_sfc(n) % q % error) - if (iv%sonde_sfc(n)% q % error == missing_r) & - iv%sonde_sfc(n)% q % qc = missing_data + if (iv%sonde_sfc(n)% q % error == missing_r) & + iv%sonde_sfc(n)% q % qc = missing_data end if end do end if @@ -346,7 +361,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ob % airep(n) % t(k) = iv % airep(n) % t(k) % inv ob % airep(n) % q(k) = iv % airep(n) % q(k) % inv - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then + if (.not. uvq_direct_local) then rh_error = iv%airep(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % airep(n) % p(k), & ob % airep(n) % t(k), & @@ -459,16 +474,16 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then - rh_error = iv%buoy(n)%q%error ! q error is rh at this stage! - call da_get_q_error(iv % buoy(n) % p % inv, & + if (.not. uvq_direct_local) then + rh_error = iv%buoy(n)%q%error ! q error is rh at this stage! + call da_get_q_error(iv % buoy(n) % p % inv, & ob % buoy(n) % t, & ob % buoy(n) % q, & iv % buoy(n) % t % error, & rh_error, q_error) - iv % buoy(n) % q % error = q_error + iv % buoy(n) % q % error = q_error - if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data + if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data end if end do end if @@ -525,6 +540,19 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) end do end if + ! [2.21] Transfer lightning obs + + if (iv%info(lightning)%nlocal > 0) then + do n = 1, iv%info(lightning)%nlocal + do k = 1, iv%info(lightning)%levels(n) + ! Copy observation variables: + ob % lightning(n) % w(k) = iv % lightning(n) % w(k) % inv + ob % lightning(n) % div(k) = iv % lightning(n) % div(k) % inv + ob % lightning(n) % qv(k) = iv % lightning(n) % qv(k) % inv + end do + end do + end if + ! Transfer AIRS retrievals: if (iv%info(airsr)%nlocal > 0) then @@ -538,7 +566,7 @@ subroutine da_fill_obs_structures(iv, ob, uvq_direct) ! Calculate q error from rh error: - if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then + if (.not. uvq_direct_local) then rh_error = iv%airsr(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % airsr(n) % p(k), & ob % airsr(n) % t(k), & diff --git a/var/da/da_obs/da_fill_obs_structures_lightning.inc b/var/da/da_obs/da_fill_obs_structures_lightning.inc new file mode 100644 index 0000000000..de96586cfe --- /dev/null +++ b/var/da/da_obs/da_fill_obs_structures_lightning.inc @@ -0,0 +1,48 @@ +subroutine da_fill_obs_structures_lightning(iv, ob) + + !---------------------------------------------------------------------------- + ! Purpose: Allocates observation structure and fills it from iv. + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !---------------------------------------------------------------------------- + + implicit none + + type (iv_type), intent(inout) :: iv ! Obs and header structure. + type (y_type), intent(out) :: ob ! (Smaller) observation structure. + + integer :: n, k ! Loop counters. + integer :: i,j + + if (trace_use) call da_trace_entry("da_fill_obs_structures_lightning") + + !--------------------------------------------------------------------------- + ! Initialise obs error factors (which will be overwritten in use_obs_errfac) + !--------------------------------------------------------------------------- + + iv % lightning_ef_w = 1.0 + iv % lightning_ef_div = 1.0 + iv % lightning_ef_qv = 1.0 + !---------------------------------------------------------------------- + ! [1.0] Allocate innovation vector and observation structures: + !---------------------------------------------------------------------- + call da_allocate_y_lightning(iv, ob) + + !---------------------------------------------------------------------- + ! [2.0] Transfer observations: + !---------------------------------------------------------------------- + + ! [2.20] Transfer lightning obs: + + if (iv%info(lightning)%nlocal > 0) then + do n = 1, iv%info(lightning)%nlocal + do k = 1, iv%info(lightning)%levels(n) + ob%lightning(n)%w(k) = iv%lightning(n)%w(k)%inv + ob%lightning(n)%div(k) = iv%lightning(n)%div(k)%inv + ob%lightning(n)%qv(k) = iv%lightning(n)%qv(k)%inv + end do + end do + end if + + if (trace_use) call da_trace_exit("da_fill_obs_structures_lightning") + +end subroutine da_fill_obs_structures_lightning diff --git a/var/da/da_obs/da_obs.f90 b/var/da/da_obs/da_obs.f90 index 998f6fa5c5..4f5f20422e 100644 --- a/var/da/da_obs/da_obs.f90 +++ b/var/da/da_obs/da_obs.f90 @@ -5,7 +5,7 @@ module da_obs da_allocate_y_chem_sfc, da_deallocate_y_chem_sfc, & #endif field_type, each_level_type,da_allocate_y, da_random_seed,da_allocate_y_rain, & - da_allocate_y_radar + da_allocate_y_radar, da_allocate_y_lightning #if (WRF_CHEM == 1) use module_domain, only : domain, x_type, xchem_type use da_chem_sfc, only : da_transform_xtoy_chem_sfc, da_transform_xtoy_chem_sfc_adj @@ -28,7 +28,7 @@ module da_obs rtm_option_crtm,use_rad, base_temp, base_lapse, base_pres, & ob_format,ob_format_ascii,filename_len, trace_use_dull, & sound, mtgirs, synop, profiler, gpsref, gpseph, gpspw, polaramv, geoamv, ships, metar, & - satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, sonde_sfc,rain, & + satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, sonde_sfc, rain, lightning, & bogus, buoy, qscat, tamdar, tamdar_sfc, pseudo, num_ob_indexes, its,ite,jds,jts,jte,ids, & #if (WRF_CHEM == 1) chemic_surf, & @@ -62,6 +62,7 @@ module da_obs use da_qscat, only : da_transform_xtoy_qscat,da_transform_xtoy_qscat_adj use da_radar, only : da_transform_xtoy_radar,da_transform_xtoy_radar_adj use da_rain, only : da_transform_xtoy_rain,da_transform_xtoy_rain_adj + use da_lightning, only : da_transform_xtoy_lightning,da_transform_xtoy_lightning_adj use da_reporting, only : da_error, message, da_warning, da_message #ifdef RTTOV use da_rttov, only : da_transform_xtoy_rttov,da_transform_xtoy_rttov_adj @@ -69,9 +70,9 @@ module da_obs use da_satem, only : da_transform_xtoy_satem, da_transform_xtoy_satem_adj use da_ships, only : da_transform_xtoy_ships, da_transform_xtoy_ships_adj use da_sound, only : da_transform_xtoy_sound, da_transform_xtoy_sonde_sfc, & - da_transform_xtoy_sound_adj, da_transform_xtoy_sonde_sfc_adj + da_transform_xtoy_sound_adj, da_transform_xtoy_sonde_sfc_adj use da_mtgirs, only : da_transform_xtoy_mtgirs, da_transform_xtoy_mtgirs_adj - use da_tamdar, only : da_transform_xtoy_tamdar, da_transform_xtoy_tamdar_adj, & + use da_tamdar, only : da_transform_xtoy_tamdar, da_transform_xtoy_tamdar_adj, & da_transform_xtoy_tamdar_sfc, da_transform_xtoy_tamdar_sfc_adj use da_ssmi, only : da_transform_xtoy_ssmt1, da_transform_xtoy_ssmt2, & da_transform_xtoy_ssmi_tb, da_transform_xtoy_ssmi_rv, & @@ -96,6 +97,7 @@ module da_obs #include "da_fill_obs_structures.inc" #include "da_fill_obs_structures_radar.inc" #include "da_fill_obs_structures_rain.inc" +#include "da_fill_obs_structures_lightning.inc" #if (WRF_CHEM == 1) #include "da_fill_obs_structures_chem_sfc.inc" #endif diff --git a/var/da/da_obs/da_obs_sensitivity.inc b/var/da/da_obs/da_obs_sensitivity.inc index 8bf9bbb65b..19d56dd9b7 100644 --- a/var/da/da_obs/da_obs_sensitivity.inc +++ b/var/da/da_obs/da_obs_sensitivity.inc @@ -506,7 +506,7 @@ subroutine da_obs_sensitivity(ktr, iv) write(unit=message(imsg),fmt='(A)') 'Impact of Conventional Observations for each observation type: ' do i = 1, num_ob_indexes if ( (i == ssmi_tb) .or. (i == ssmt1) .or. (i == ssmt2) .or. & - (i == radar ) .or. (i == radiance) .or. (i == airsr) .or. & + (i == radar ) .or. (i == radiance) .or. (i == airsr) .or. (i == lightning) .or. & (i == sonde_sfc) .or. (i == tamdar_sfc) .or. (i == rain) ) cycle imsg = imsg + 1 write(unit=message(imsg),fmt='(3x,a,e15.5)') obs_names(i), SUM(ktd_global(i,:)) diff --git a/var/da/da_obs/da_transform_xtoy.inc b/var/da/da_obs/da_transform_xtoy.inc index 83817517a8..2b99bde777 100644 --- a/var/da/da_obs/da_transform_xtoy.inc +++ b/var/da/da_obs/da_transform_xtoy.inc @@ -51,6 +51,7 @@ subroutine da_transform_xtoy(cv_size, cv, grid, iv, y) if (iv%info(bogus)%nlocal > 0) call da_transform_xtoy_bogus (grid, iv, y) if (iv%info(airsr)%nlocal > 0) call da_transform_xtoy_airsr (grid, iv, y) if (iv%info(pseudo)%nlocal > 0) call da_transform_xtoy_pseudo (grid, iv, y) + if (iv%info(lightning)%nlocal > 0) call da_transform_xtoy_lightning(grid, iv, y) #if (WRF_CHEM == 1) if (iv%info(chemic_surf)%nlocal > 0) & diff --git a/var/da/da_obs/da_transform_xtoy_adj.inc b/var/da/da_obs/da_transform_xtoy_adj.inc index dbbe9ddd15..2c8cf6cf7d 100644 --- a/var/da/da_obs/da_transform_xtoy_adj.inc +++ b/var/da/da_obs/da_transform_xtoy_adj.inc @@ -111,6 +111,7 @@ subroutine da_transform_xtoy_adj(cv_size, cv, grid, iv, jo_grad_y, jo_grad_x & if (iv%info(bogus)%nlocal > 0) call da_transform_xtoy_bogus_adj (grid, iv, jo_grad_y, jo_grad_x) if (iv%info(airsr)%nlocal > 0) call da_transform_xtoy_airsr_adj (iv, jo_grad_y, jo_grad_x) if (iv%info(pseudo)%nlocal > 0) call da_transform_xtoy_pseudo_adj (iv, jo_grad_y, jo_grad_x) + if (iv%info(lightning)%nlocal> 0) call da_transform_xtoy_lightning_adj(grid, iv, jo_grad_y, jo_grad_x) #if defined(CRTM) || defined(RTTOV) if (use_rad) then diff --git a/var/da/da_obs_io/da_final_write_obs.inc b/var/da/da_obs_io/da_final_write_obs.inc index 02b603876f..9c7f1453fa 100644 --- a/var/da/da_obs_io/da_final_write_obs.inc +++ b/var/da/da_obs_io/da_final_write_obs.inc @@ -536,6 +536,26 @@ subroutine da_final_write_obs(it,iv) end do end if + !------------------------------------------------------------------ + ! [22] writing lightning + !------------------------------------------------------------------ + + num_obs = 0 + if (iv%info(lightning)%nlocal > 0) then + do n = 1, iv%info(lightning)%nlocal + if(iv%info(lightning)%proc_domain(1,n)) num_obs = num_obs + 1 + end do + end if + call da_proc_sum_int(num_obs) + if_wind_sd = .false. + if (num_obs > 0 .and. rootproc) then + write(omb_unit,'(a20,i8)')'lightning', num_obs + num_obs = 0 + do k = 0,num_procs-1 + call da_read_omb_tmp(filename(k),iunit,num_obs,'lightning',5,if_wind_sd) + end do + end if + if (rootproc) then close(iunit) @@ -548,5 +568,3 @@ subroutine da_final_write_obs(it,iv) if (trace_use) call da_trace_exit("da_final_write_obs") end subroutine da_final_write_obs - - diff --git a/var/da/da_obs_io/da_obs_io.f90 b/var/da/da_obs_io/da_obs_io.f90 index 7e25443288..7c9760ed1a 100644 --- a/var/da/da_obs_io/da_obs_io.f90 +++ b/var/da/da_obs_io/da_obs_io.f90 @@ -4,7 +4,7 @@ module da_obs_io use da_control, only : xmiss, missing_r, fmt_each, fmt_info, trace_use, & fmt_srfc, filtered_obs_unit, num_procs,missing, ierr,comm, rand_unit, & - obs_qc_pointer, rootproc, omb_unit,omb_add_noise,use_airepobs, & + obs_qc_pointer, rootproc, omb_unit,omb_add_noise,use_airepobs, use_lightningobs, & use_airepobs,use_bogusobs,use_gpspwobs,use_gpsztdobs,use_gpsrefobs,use_geoamvobs, & use_metarobs,use_profilerobs,use_pilotobs,use_buoyobs,use_shipsobs,use_rainobs, & use_synopobs,use_soundobs,use_mtgirsobs,use_tamdarobs,use_qscatobs,use_radarobs, & @@ -23,7 +23,7 @@ module da_obs_io obs_names, num_ob_indexes, fm_index, ids,ide, ite, jte, & sound, mtgirs,synop, pilot, satem, geoamv, polaramv, airep, gpspw, gpsref, & tamdar, tamdar_sfc, metar, ships, ssmi_rv, ssmi_tb, ssmt1, ssmt2, qscat, profiler, buoy, bogus, pseudo, & - radar, radiance, airsr, sonde_sfc, trace_use_dull, num_fgat_time, time_slots, myproc, & + radar, radiance, airsr, sonde_sfc, trace_use_dull, num_fgat_time, time_slots, myproc, lightning, & qmarker_retain, anal_type_verify, top_km_gpsro, bot_km_gpsro, thin_rainobs, & sfc_assi_options, sfc_assi_options_1, sfc_assi_options_2,print_detail_rain,max_rain_input,rain, & pi, ob_format_gpsro, ob_format_ascii, analysis_date, kms,kme, v_interp_h,v_interp_p, & @@ -33,6 +33,7 @@ module da_obs_io lsac_use_u, lsac_use_v, lsac_use_t, lsac_use_q, lsac_u_error, lsac_v_error, lsac_t_error, lsac_q_error, & gpsro_drift, max_gpseph_input, use_gpsephobs, gpseph, gpseph_loadbalance, kds, kde, kts, kte, & use_radar_rhv, use_radar_rqv, use_radar_rf, use_radar_rv, multi_inc, & + use_lightning_w, use_lightning_div, use_lightning_qv, lightning_min_rh, min_flashrate, & thin_conv_opt, no_thin, thin_single, thin_multi, thin_superob, thin_superob_hv, & thin_mesh_vert_conv, use_satwnd_bufr, uv_error_opt, uv_error_val, error_opt_nml @@ -54,7 +55,7 @@ module da_obs_io use da_define_structures, only : iv_type, multi_level_type, multi_level_type_BUFR, & radar_multi_level_type, y_type, field_type, each_level_type, & radar_each_level_type, info_type, model_loc_type,gpsref_type, rain_single_level_type, rain_each_type, & - gpseph_type + gpseph_type, lightning_each_level_type, lightning_multi_level_type use da_grid_definitions, only : da_ffdduv,da_ffdduv_model,da_ffdduv_diagnose use da_obs, only : da_count_filtered_obs,da_check_missing,da_obs_proc_station, da_set_obs_missing, da_set_3d_obs_missing use da_par_util1, only : da_proc_sum_int @@ -97,6 +98,8 @@ module da_obs_io #include "da_scan_obs_ascii.inc" #include "da_read_obs_radar.inc" #include "da_scan_obs_radar.inc" +#include "da_read_obs_lightning.inc" +#include "da_scan_obs_lightning.inc" #include "da_scan_obs_rain.inc" #include "da_read_obs_rain.inc" #if (WRF_CHEM == 1) diff --git a/var/da/da_obs_io/da_read_iv_for_multi_inc.inc b/var/da/da_obs_io/da_read_iv_for_multi_inc.inc index f2ad1bd4b4..ca40e42f36 100644 --- a/var/da/da_obs_io/da_read_iv_for_multi_inc.inc +++ b/var/da/da_obs_io/da_read_iv_for_multi_inc.inc @@ -824,6 +824,35 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) close (unit_in) end if ! nobs_tot > 0 + ! [26] lightning obs: + + if (iv%info(lightning)%plocal(iv%time)-iv%info(lightning)%plocal(iv%time-1) > 0) then + + open(unit=unit_in,file=trim(filename)//'.lightning',form='formatted',status='old',iostat=ios) + if (ios /= 0) Then + call da_error(__FILE__,__LINE__, & + (/"Cannot open file"//filename/)) + end if + + read(unit_in,'(a20,i8)', end = 999, err = 1000) ob_type_string, num_obs + if ( trim(adjustl(ob_type_string)) .ne. 'lightning' ) & + call da_error(__FILE__,__LINE__, & + (/"Cannot find lightning marker. "/)) + gn = 0 + do n = iv%info(lightning)%plocal(iv%time-1) + 1, & + iv%info(lightning)%plocal(iv%time) + call da_search_obs (ob_type_string, unit_in, num_obs, n, iv, found_flag) + if (found_flag .eqv. .false.) & + call da_error(__FILE__,__LINE__, & + (/"Cannot find lightning obs. "/)) + gn = gn + 1 + end do + if (gn /= iv%info(lightning)%plocal(iv%time)-iv%info(lightning)%plocal(iv%time-1)) & + call da_error(__FILE__,__LINE__, & + (/"Unequal obs. found "/)) + close (unit_in) + end if + 999 continue close (unit_in) call da_free_unit(unit_in) diff --git a/var/da/da_obs_io/da_read_obs_lightning.inc b/var/da/da_obs_io/da_read_obs_lightning.inc new file mode 100644 index 0000000000..4fd0f53b32 --- /dev/null +++ b/var/da/da_obs_io/da_read_obs_lightning.inc @@ -0,0 +1,220 @@ +subroutine da_read_obs_lightning (iv, filename, grid) + + !----------------------------------------------------------------------- + ! Purpose: Read the lightning observation file + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------------------------! + + implicit none + + type (iv_type), intent(inout) :: iv + character(len=*), intent(in) :: filename + type(domain), intent(in) :: grid ! first guess state. + + integer :: i, n, iost + integer :: iunit + + integer :: i1, j1, k ! Index dimension. + real :: dx, dxm ! Interpolation weights + real :: dy, dym ! Interpolation weights + real :: zlcl + + type (lightning_multi_level_type) :: platform + + character (len = 120) :: char_total_lightning, char_total_levels + character (len = 160) :: info_string + integer :: total_lightning, nlevels, lightning_qc, rh_indicator + real :: flashrate, wmax, lightning_error + real, allocatable,dimension(:):: height, coff + logical :: outside, outside_all + integer :: nlocal + + if (trace_use) call da_trace_entry("da_read_obs_lightning") + + nlocal = 0 + + ! 1. open file + call da_get_unit(iunit) + open(unit = iunit, & + FILE = trim(filename), & + FORM = 'FORMATTED', & + ACCESS = 'SEQUENTIAL', & + iostat = iost, & + STATUS = 'OLD') + + if (iost /= 0) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error",iost," opening lightning obs file "//trim(filename) + call da_warning(__FILE__,__LINE__,message(1:1)) + call da_free_unit(iunit) + if (trace_use) call da_trace_exit("da_read_obs_lightning") + return + end if + + ! 2. read basic info + + ! 2.1 read the number of total lightning observation and vertical layers + read (unit=iunit, fmt = '(A)', iostat = iost) char_total_lightning + read (unit=iunit, fmt = '(A)', iostat = iost) char_total_levels + read (unit=char_total_levels(9:15),fmt='(I7)', iostat = iost) nlevels + + ! skip one line + read (unit=iunit, fmt = '(A)', iostat = iost) + + ! 2.2 read height and coefficient + allocate(height(nlevels)) + allocate(coff(nlevels)) + do i = 1, nlevels + read (unit = iunit, iostat = iost, fmt = '(2F12.3)') height(i), coff(i) + end do + + ! 2.3 read header info + head_info: do + read (unit=iunit, fmt = '(A)', iostat = iost) info_string + if (iost /= 0) then + write(unit=message(1),fmt='(A,I3,A,I3)') & + "Error",iost,"reading lightning obs header on unit",iunit + call da_warning(__FILE__,__LINE__,message(1:1)) + if (trace_use) call da_trace_exit("da_scan_obs_lightning") + return + end if + if (info_string(1:6) == 'data ') exit + end do head_info + + ! 2.4 read total lightning data info + read (unit=char_total_lightning (8:14),fmt='(I7)', iostat = iost) total_lightning + + ! 2.5 skip one line + read (unit=iunit, fmt = '(A)', iostat = iost) + + ! 3. read lightning data + reports: do n = 1, total_lightning + ! 3.1 read station general info + read (unit = iunit, iostat = iost, & + fmt = '(A12,1X,A19,1X,I6,2(F12.3,2X),F8.1,1X,A5)') & + platform%info%platform, & + platform%info%date_char, & + platform%info%levels, & + platform%info%lat, & + platform%info%lon, & + platform%info%elv, & + platform%info%id + + call da_llxy (platform%info, platform%loc, outside, outside_all) + +! Height information is from xb, get horizontal interpolation weights: + i1 = platform%loc%i + j1 = platform%loc%j + dx = platform%loc%dx + dy = platform%loc%dy + dxm = platform%loc%dxm + dym = platform%loc%dym + + ! 3.2 read lightning flash rate and its qc and error info + read (unit = iunit, fmt = '(F12.3,I4,F12.3,I4)') flashrate, lightning_qc, lightning_error, rh_indicator + + !turn lighting flash rate into the maximum wmax + if(flashrate .ge. min_flashrate .and. flashrate .le. min_flashrate+10.0)then + wmax = 5!14.6 + end if + if(flashrate .gt.min_flashrate+10.0 .and. flashrate .le. min_flashrate+20.0)then + wmax = 8!17.07 + end if + if(flashrate .gt.min_flashrate+20.0 .and. flashrate.le.min_flashrate+30.0)then + wmax = 12!18.67 + end if + if(flashrate .gt.min_flashrate+30.0)then + wmax = 15!24.4 !m/s + end if + + zlcl = 125.0*(grid%xb%t(i1,j1,1)-grid%xb%td(i1,j1,1)) + grid%xb%terr(i1,j1) + zlcl = amax1(grid%xb%terr(i1,j1)+1000.,zlcl) + zlcl = amin1(3000. ,zlcl) + + do i = 1, nlevels !vertical layers + platform%each(i) = lightning_each_level_type(missing_r, missing, -1.0, & + field_type(missing_r, missing, missing_r, missing, missing_r), & ! w + field_type(missing_r, missing, missing_r, missing, missing_r), & ! div + field_type(missing_r, missing, missing_r, missing, missing_r)) ! qv + + platform%each(i)%height = grid%xb%h(i1,j1,k) !height(i) + + if(flashrate .ge. min_flashrate .and. i .gt. 1) then + ! vertical velocity + platform%each(i)%w%inv = wmax*coff(i) + platform%each(i)%w%qc = 0 + platform%each(i)%w%error = amax1(1.0, 0.20*abs(platform%each(i)%w%inv)) + ! divergence + platform%each(i)%div%inv = -wmax*(coff(i)-coff(i-1))/(height(i)-height(i-1)) + platform%each(i)%div%qc = 0 + platform%each(i)%div%error = amax1(0.0001, 0.20*abs(platform%each(i)%div%inv)) + else + platform%each(i)%w%qc = missing_data + platform%each(i)%w%error = missing_r + platform%each(i)%div%qc = missing_data + platform%each(i)%div%error = missing_r + end if + + + if(flashrate .ge. 10.0 .and. rh_indicator .gt. -1 .and. height(i) .ge. zlcl .and. height(i) .le.15000)then + platform%each(i)%qv%inv = 0.01*(2*rh_indicator+lightning_min_rh)*grid%xb%qs(i1,j1,i) + platform%each(i)%qv%qc = 0 + platform%each(i)%qv%error = amax1(0.001,0.20*platform%each(i)%qv%inv) + else + platform%each(i)%qv%qc = missing_data + platform%each(i)%qv%error = missing_r + end if + end do !vertical layers + + if(outside)then + cycle + end if + nlocal = nlocal+1 + + iv%info(lightning)%levels(nlocal) = nlevels + iv%info(lightning)%name(nlocal) = platform%info%name + iv%info(lightning)%platform(nlocal) = platform%info%platform + iv%info(lightning)%id(nlocal) = platform%info%id + iv%info(lightning)%date_char(nlocal) = platform%info%date_char + iv%info(lightning)%lat(:,nlocal) = platform%info%lat + iv%info(lightning)%lon(:,nlocal) = platform%info%lon + iv%info(lightning)%elv(nlocal) = platform%info%elv + iv%info(lightning)%pstar(nlocal) = platform%info%pstar + + iv%info(lightning)%slp(nlocal) = platform%loc%slp + iv%info(lightning)%pw(nlocal) = platform%loc%pw + iv%info(lightning)%x(:,nlocal) = platform%loc%x + iv%info(lightning)%y(:,nlocal) = platform%loc%y + iv%info(lightning)%i(:,nlocal) = platform%loc%i + iv%info(lightning)%j(:,nlocal) = platform%loc%j + iv%info(lightning)%dx(:,nlocal) = platform%loc%dx + iv%info(lightning)%dxm(:,nlocal) = platform%loc%dxm + iv%info(lightning)%dy(:,nlocal) = platform%loc%dy + iv%info(lightning)%dym(:,nlocal) = platform%loc%dym + iv%info(lightning)%proc_domain(:,nlocal) = platform%loc%proc_domain + iv%info(lightning)%obs_global_index(nlocal) = nlocal + + allocate(iv%lightning(nlocal)%height(1:nlevels)) + allocate(iv%lightning(nlocal)%height_qc(1:nlevels)) + allocate(iv%lightning(nlocal)%w(1:nlevels)) + allocate(iv%lightning(nlocal)%qv(1:nlevels)) + allocate(iv%lightning(nlocal)%div(1:nlevels)) + + do i = 1, nlevels + iv%lightning(nlocal)%height(i) = platform%each(i)%height + iv%lightning(nlocal)%height_qc(i)= platform%each(i)%height_qc + iv%lightning(nlocal)%w(i) = platform%each(i)%w + iv%lightning(nlocal)%qv(i) = platform%each(i)%qv + iv%lightning(nlocal)%div(i) = platform%each(i)%div + end do + + end do reports + deallocate(height) + deallocate(coff) + close(iunit) + call da_free_unit(iunit) + + if (trace_use) call da_trace_exit("da_read_obs_lightning") + + +end subroutine da_read_obs_lightning diff --git a/var/da/da_obs_io/da_read_omb_tmp.inc b/var/da/da_obs_io/da_read_omb_tmp.inc index f4a0ad47ef..ff83dd642a 100644 --- a/var/da/da_obs_io/da_read_omb_tmp.inc +++ b/var/da/da_obs_io/da_read_omb_tmp.inc @@ -39,8 +39,10 @@ subroutine da_read_omb_tmp(filename,unit_in,num,obs_type_in,nc,if_wind_sd) spd_obs, spd_inv, spd_err, spd_inc, & ref_obs, ref_inv, ref_error, ref_inc, & eph_obs, eph_inv, eph_error, eph_inc, & - rain_obs, rain_inv, rain_error, rain_inc, zk - integer :: u_qc, v_qc, t_qc, p_qc, q_qc, tpw_qc, spd_qc, ref_qc, rain_qc + rain_obs, rain_inv, rain_error, rain_inc, zk, & + w_obs, w_inv, w_error, w_inc, & ! lightning + div_obs, div_inv, div_error, div_inc ! lightning + integer :: u_qc, v_qc, t_qc, p_qc, q_qc, tpw_qc, spd_qc, ref_qc, rain_qc, w_qc, div_qc #if (WRF_CHEM == 1) real :: chem_obs, chem_inv, chem_err, chem_inc, & chem_obs2, chem_inv2, chem_err2, chem_inc2, & @@ -453,6 +455,34 @@ subroutine da_read_omb_tmp(filename,unit_in,num,obs_type_in,nc,if_wind_sd) if (if_write) exit reports cycle reports + case ('lightning' ) + if (num_obs > 0) then + do n = 1, num_obs + read(unit_in,'(2i8)') levels, ifgat + if (if_write) then + write(omb_unit,'(2i8)')levels, ifgat + num = num + 1 + end if + do k = 1, levels + read(unit_in,'(2i8,a5,2f9.2,f17.7,3(2f17.7,i8,2f17.7))', err= 1000)& + kk,l, stn_id, & ! Station + lat, lon, height, & ! Lat/lon, height + w_obs, w_inv, w_qc, w_error, w_inc, & ! vertical velocity + div_obs, div_inv, div_qc, div_error, div_inc, & ! divergence + q_obs, q_inv, q_qc, q_error, q_inc ! water vapor + if (if_write) & + write(omb_unit,'(2i8,a5,2f9.2,f17.7,3(2f17.7,i8,2f17.7))', err= 1000)& + num,k,stn_id, & ! Station + lat, lon, height, & ! Lat/lon, height + w_obs, w_inv, w_qc, w_error, w_inc, & ! vertical velocity + div_obs, div_inv, div_qc, div_error, div_inc, & ! divergence + q_obs, q_inv, q_qc, q_error, q_inc ! water vapor + end do + end do + end if + if (if_write) exit reports + cycle reports + #if (WRF_CHEM == 1) case ('chem' ) if (num_obs > 0) then diff --git a/var/da/da_obs_io/da_scan_obs_lightning.inc b/var/da/da_obs_io/da_scan_obs_lightning.inc new file mode 100644 index 0000000000..d21f4304d2 --- /dev/null +++ b/var/da/da_obs_io/da_scan_obs_lightning.inc @@ -0,0 +1,130 @@ +subroutine da_scan_obs_lightning (iv, filename, grid) + + !--------------------------------------------------------------------------- + ! Purpose: Scan the lightning observation file + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !--------------------------------------------------------------------------- + + implicit none + + type (iv_type), intent(inout) :: iv + character(len=*), intent(in) :: filename + type(domain), intent(in) :: grid ! first guess state. + + integer :: i, n, iost + integer :: iunit + + type (lightning_multi_level_type) :: platform + + character (len = 120) :: char_total_lightning, char_total_levels + character (len = 160) :: info_string + integer :: total_lightning, nlevels, lightning_qc, rh_indicator + real :: flashrate, lightning_error + real, allocatable,dimension(:):: height, coff + logical :: outside, outside_all + integer :: nlocal, ntotal + + if (trace_use) call da_trace_entry("da_scan_obs_lightning") + + nlocal = 0 + ntotal = 0 + + ! 1. open file + ! ============ + call da_get_unit(iunit) + open(unit = iunit, & + FILE = trim(filename), & + FORM = 'FORMATTED', & + ACCESS = 'SEQUENTIAL', & + iostat = iost, & + STATUS = 'OLD') + + if (iost /= 0) then + write(unit=message(1),fmt='(A,I5,A)') & + "Error",iost," opening lightning obs file "//trim(filename) + call da_warning(__FILE__,__LINE__,message(1:1)) + call da_free_unit(iunit) + if (trace_use) call da_trace_exit("da_scan_obs_lightning") + return + end if + + ! 2. read basic info + + ! 2.1 read the number of total lightning observation and vertical layers + read (unit=iunit, fmt = '(A)', iostat = iost) char_total_lightning + read (unit=iunit, fmt = '(A)', iostat = iost) char_total_levels + read (unit=char_total_levels(9:15),fmt='(I7)', iostat = iost) nlevels + + ! skip one line + read (unit=iunit, fmt = '(A)', iostat = iost) + + ! 2.2 read height and coefficient + allocate(height(nlevels)) + allocate(coff(nlevels)) + do i = 1, nlevels + read (unit = iunit, iostat = iost, fmt = '(2F12.3)') height(i), coff(i) + end do + + if (iost /= 0) then + ! Does matter if present and unreadable + call da_error(__FILE__,__LINE__, & + (/"Cannot read lightning file"/)) + end if + + ! 2.3 read header info + head_info: do + read (unit=iunit, fmt = '(A)', iostat = iost) info_string + if (iost /= 0) then + write(unit=message(1),fmt='(A,I3,A,I3)') & + "Error",iost,"reading lightning obs header on unit",iunit + call da_warning(__FILE__,__LINE__,message(1:1)) + if (trace_use) call da_trace_exit("da_scan_obs_lightning") + return + end if + if (info_string(1:6) == 'data ') exit + end do head_info + + ! 2.4 read total lightning data info + read (unit=char_total_lightning(8:14),fmt='(I7)', iostat = iost) total_lightning + + ! 2.5 skip one line + read (unit=iunit, fmt = '(A)', iostat = iost) + + + ! 3. read lightning data + reports: do n = 1, total_lightning + ! 3.1 read station general info + read (unit = iunit, iostat = iost, & + fmt = '(A12,1X,A19,1X,I6,2(F12.3,2X),F8.1,1X,A5)') & + platform%info%platform, & + platform%info%date_char, & + platform%info%levels, & + platform%info%lat, & + platform%info%lon, & + platform%info%elv, & + platform%info%id + + ! 3.2 read lightning flash rate and its qc and error info + read (unit = iunit, fmt = '(F12.3,I4,F12.3,I4)') flashrate, lightning_qc, lightning_error, rh_indicator + + call da_llxy (platform%info, platform%loc, outside, outside_all) + ntotal = ntotal + 1 + if(outside)then + cycle + end if + nlocal = nlocal + 1 + end do reports + + iv%info(lightning)%max_lev = nlevels + iv%info(lightning)%ntotal = ntotal + iv%info(lightning)%nlocal = nlocal + + deallocate(height) + deallocate(coff) + close (iunit) + call da_free_unit(iunit) + + if (trace_use) call da_trace_exit("da_scan_obs_lightning") + +end subroutine da_scan_obs_lightning + diff --git a/var/da/da_obs_io/da_search_obs.inc b/var/da/da_obs_io/da_search_obs.inc index b664655497..9fb3439960 100644 --- a/var/da/da_obs_io/da_search_obs.inc +++ b/var/da/da_obs_io/da_search_obs.inc @@ -740,6 +740,34 @@ subroutine da_search_obs (ob_type_string, unit_in, num_obs, nth, iv, found_flag) rewind (unit_in) read(unit_in,*) + CASE ('lightning') + + do n = 1, num_obs + read(unit_in,'(2i8,2E22.13)') n_dummy, levels, lat, lon + + if ( abs(iv%info(lightning)%lat(1,nth) - lat ) < MIN_ERR .and. & + abs(iv%info(lightning)%lon(1,nth) - lon ) < MIN_ERR ) then + + do k = 1, levels + read(unit_in,'(3(E22.13,i8,3E22.13))')& + iv%lightning(nth)%w(k),& + iv%lightning(nth)%div(k),& + iv%lightning(nth)%qv(k) + enddo + + !found_flag = .true. + rewind (unit_in) + read(unit_in,*) + if (trace_use) call da_trace_exit("da_search_obs") + return + else + read(unit_in,*) + endif + enddo + !found_flag = .false. + rewind (unit_in) + read(unit_in,*) + CASE default; write(unit=message(1), fmt='(a,a20,a,i3)') & diff --git a/var/da/da_obs_io/da_write_iv_for_multi_inc.inc b/var/da/da_obs_io/da_write_iv_for_multi_inc.inc index 1d359c7f5f..523a10cf95 100644 --- a/var/da/da_obs_io/da_write_iv_for_multi_inc.inc +++ b/var/da/da_obs_io/da_write_iv_for_multi_inc.inc @@ -890,6 +890,35 @@ subroutine da_write_iv_for_multi_inc(file_index, iv) end if ! nobs_tot > 0 + ! [26] lightning obs: + + if (iv%info(lightning)%plocal(iv%time) - iv%info(lightning)%plocal(iv%time-1) > 0) then + + open (unit=ounit,file=trim(filename)//'.lightning',form='formatted',status='replace', & + iostat=ios) + if (ios /= 0) then + call da_error(__FILE__,__LINE__, & + (/"Cannot open conventional observation omb file"//filename/)) + end if + + write(ounit,'(a20,i8)')'radar', iv%info(lightning)%plocal(iv%time) - & + iv%info(lightning)%plocal(iv%time-1) + do n = iv%info(lightning)%plocal(iv%time-1) + 1, & + iv%info(lightning)%plocal(iv%time) + write(ounit,'(2i8,2E22.13)')& + n, iv%info(lightning)%levels(n), & + iv%info(lightning)%lat(1,n), & ! Latitude + iv%info(lightning)%lon(1,n) ! Longitude + do k = 1 , iv%info(lightning)%levels(n) + write(ounit,'(E22.13,(E22.13,i8,3E22.13))')& + iv%lightning(n)%w(k) ,& ! lightning-w + iv%lightning(n)%div(k), & ! lightning-div + iv%lightning(n)%qv(k) ! lightning-qv + enddo + end do + close (ounit) + end if + !------------------------------------------------------------------------------- diff --git a/var/da/da_obs_io/da_write_obs.inc b/var/da/da_obs_io/da_write_obs.inc index 9d1ba17aa2..7148b480d2 100644 --- a/var/da/da_obs_io/da_write_obs.inc +++ b/var/da/da_obs_io/da_write_obs.inc @@ -935,6 +935,51 @@ subroutine da_write_obs(it,ob, iv, re) end if end do end if + + !! lightning + num_obs = 0 + do n = 1, iv%info(lightning)%nlocal + if (iv%info(lightning)%proc_domain(1,n)) num_obs = num_obs + 1 + end do + if (num_obs > 0) then + write(ounit,'(a20,i8)')'lightning', num_obs + num_obs = 0 + do n = 1, iv%info(lightning)%nlocal + do itime = 1, num_fgat_time + if ( n >= iv%info(lightning)%plocal(itime-1)+1 .and. & + n <= iv%info(lightning)%plocal(itime) ) then + ifgat = itime + exit + end if + end do + if (iv%info(lightning)%proc_domain(1,n)) then + num_obs = num_obs + 1 + write(ounit,'(2i8)')iv%info(lightning)%levels(n), ifgat + do k = 1, iv%info(lightning)%levels(n) + write(ounit,'(2i8,a5,2f9.2,f17.7,3(2f17.7,i8,2f17.7))')& + num_obs , k, iv%info(lightning)%id(n), & ! Station + iv%info(lightning)%lat(1,n), & ! Latitude + iv%info(lightning)%lon(1,n), & ! Longitude + iv%lightning(n)%height(k), & ! Obs Height + ob%lightning(n)%w(k), & + iv%lightning(n)%w(k)%inv, & + iv%lightning(n)%w(k)%qc, & + iv%lightning(n)%w(k)%error, & + re%lightning(n)%w(k), & + ob%lightning(n)%div(k), & + iv%lightning(n)%div(k)%inv, & + iv%lightning(n)%div(k)%qc, & + iv%lightning(n)%div(k)%error,& + re%lightning(n)%div(k), & + ob%lightning(n)%qv(k), & + iv%lightning(n)%qv(k)%inv, & + iv%lightning(n)%qv(k)%qc, & + iv%lightning(n)%qv(k)%error, & + re%lightning(n)%qv(k) + end do + end if + end do + end if close (ounit) call da_free_unit(ounit) diff --git a/var/da/da_radar/da_get_innov_vector_radar.inc b/var/da/da_radar/da_get_innov_vector_radar.inc index 44fcc0c83f..bddcda85c3 100644 --- a/var/da/da_radar/da_get_innov_vector_radar.inc +++ b/var/da/da_radar/da_get_innov_vector_radar.inc @@ -50,7 +50,7 @@ subroutine da_get_innov_vector_radar (it, grid, ob, iv) integer :: irv, irvf integer :: irf, irff - real :: alog_10, czr,czs,czg, zrr,zds,zws,zg,rze + real :: alog_10, czrn, czds, czws, czgr, zrn, zds, zws, zgr, rze real :: ob_radar_rf, bg_rze, bg_rf real :: cwr, cws ! weighting coefficient for mixing ratio @@ -63,10 +63,30 @@ subroutine da_get_innov_vector_radar (it, grid, ob, iv) logical :: echo_non_precip, echo_rf_good + !-------------------------------------------------------- + ! for background-dependent hydrmeteor retrieval scheme + !-------------------------------------------------------- + character(len=filename_len) :: hydro_weight_file + integer :: hydro_weight_unit + integer :: tot_h_index, tot_z_index + integer :: ii, jj, kk, nk + integer :: h_index, z_index + logical :: file_exist, qg_exist + real :: zern_ratio, zews_ratio, zeds_ratio, zegr_ratio ! contributions of each hydrometeor to total reflectivity + real, allocatable :: num_sample(:,:) ! number of samples from the background + real, allocatable :: avg_zern(:,:) ! ze contributed by bin-averaged rainwater + real, allocatable :: avg_zeds(:,:) ! ze contributed by bin-averaged dry snow + real, allocatable :: avg_zews(:,:) ! ze contributed by bin-averaged wet snow + real, allocatable :: avg_zegr(:,:) ! ze contributed by bin-averaged graupel + real, allocatable :: avg_qrn(:,:) ! bin-averaged rainwater + real, allocatable :: avg_qds(:,:) ! bin-averaged dry snow + real, allocatable :: avg_qws(:,:) ! bin-averaged wet snow + real, allocatable :: avg_qgr(:,:) ! bin-averaged graupel + real, allocatable :: ave_rho(:,:) ! bin-averaged air density + !------------------------ ! for jung et al 2008 !------------------------ - real :: qvp,qra,qsn,qgr ! mixing ratio real :: dqra,dqsn,dqgr,dtmk,dqvp real :: dqnr,dqns,dqng @@ -83,10 +103,10 @@ subroutine da_get_innov_vector_radar (it, grid, ob, iv) ! Ze=zv*(ro*v)**1.75 ! Zdb=10*log10(Ze) - zrr = 3.63*1.00e+9 ! rainwater + zrn = 3.63*1.00e+9 ! rainwater zds = 9.80*1.00e+8 ! dry snow zws = 4.26*1.00e+11 ! wet snow - zg = 4.33*1.00e+10 ! grauple + zgr = 4.33*1.00e+10 ! grauple !------------------------ ! for jung et al 2008 @@ -240,6 +260,128 @@ END IF end do end if ! lcl for use_radar_rqv + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! background-dependent hydrometer retrieval scheme ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (use_radar_rhv .and. radar_rhv_opt == 2 ) then + !! allocate variables + tot_h_index = 40 ! from 500 m to 20 km, at an interval of 500 m + tot_z_index = 7 ! from -5 dBZ to 65 dBZ, at an interval of 10 dBZ + allocate (num_sample(tot_h_index,tot_z_index)) + allocate (avg_zern(tot_h_index,tot_z_index)) + allocate (avg_zeds(tot_h_index,tot_z_index)) + allocate (avg_zews(tot_h_index,tot_z_index)) + allocate (avg_zegr(tot_h_index,tot_z_index)) + allocate (avg_qrn(tot_h_index,tot_z_index)) + allocate (avg_qds(tot_h_index,tot_z_index)) + allocate (avg_qws(tot_h_index,tot_z_index)) + allocate (avg_qws(tot_h_index,tot_z_index)) + allocate (avg_qgr(tot_h_index,tot_z_index)) + allocate (ave_rho(tot_h_index,tot_z_index)) + + !! variable initialization + num_sample = 0. + avg_qrn = 0. + avg_qws = 0. + avg_qds = 0. + avg_qgr = 0. + ave_rho = 0. + avg_zern = 0. + avg_zews = 0. + avg_zeds = 0. + avg_zegr = 0. + + !! read historical statistics from hydro_mean.dat if available + hydro_weight_file='hydro_mean.dat' + inquire(file=trim(hydro_weight_file), exist=file_exist) + if (file_exist) then + call da_get_unit(hydro_weight_unit) + open(unit=hydro_weight_unit, file=trim(hydro_weight_file), form='FORMATTED') + read(unit=hydro_weight_unit, fmt='(A)') + do z_index=1,tot_z_index + do h_index=1,tot_h_index + read(hydro_weight_unit, fmt='(2(10x), 4(f19.9,2x))') & + avg_zern(h_index,z_index), avg_zews(h_index,z_index), avg_zeds(h_index,z_index), avg_zegr(h_index,z_index) + end do + end do + close(hydro_weight_unit) + call da_free_unit(hydro_weight_unit) + end if + + !! calculate sum of background states in the current processor + do kk=kds, kde + do jj=jps, jpe + do ii=ips, ipe + !! calculate background reflectivity + call da_radar_rf(grid%xb%qrn(ii,jj,kk), grid%xb%qsn(ii,jj,kk), grid%xb%qgr(ii,jj,kk), & + grid%xb%t(ii,jj,kk)-273.15, grid%xb%rho(ii,jj,kk), bg_rze) + bg_rf = 10.*log10(bg_rze) + !! get the index of reflectvity + z_index = nint(bg_rf/10.)+1 + z_index = max(z_index, 0) ! set to non-precip if below -5 dBZ + z_index = min(z_index, tot_z_index) ! set to 65 dBZ if above + !! get the height index + h_index = nint(grid%xb%h(ii,jj,kk)/500.) + h_index = max(h_index, 1) ! set to 500 m if below + h_index = min(h_index,tot_h_index) ! set to 20 km if above + + !! Sum of the model states of different model levels and reflectivity thresholds + if (z_index .ne. 0 ) then + avg_qrn(h_index,z_index) = avg_qrn(h_index,z_index) + grid%xb%qrn(ii,jj,kk) + if ( grid%xb%t(ii,jj,kk) > 273.15 ) then + avg_qws(h_index,z_index) = avg_qws(h_index,z_index) + grid%xb%qsn(ii,jj,kk) + else + avg_qds(h_index,z_index) = avg_qds(h_index,z_index) + grid%xb%qsn(ii,jj,kk) + end if + avg_qgr(h_index,z_index) = avg_qgr(h_index,z_index) + grid%xb%qgr(ii,jj,kk) + ave_rho(h_index,z_index) = ave_rho(h_index,z_index) + grid%xb%rho(ii,jj,kk) + num_sample(h_index,z_index) = num_sample(h_index,z_index) + 1. + end if + end do ! west-east + end do ! south-north + end do ! bottom-top + + !! sum of all processors and get the averaged background states + do z_index=1,tot_z_index + do h_index=1,tot_h_index + num_sample(h_index,z_index) = wrf_dm_sum_real(num_sample(h_index,z_index)) + if (num_sample(h_index,z_index) .gt. 0) then + ave_rho(h_index,z_index) = wrf_dm_sum_real(ave_rho(h_index,z_index)) / num_sample(h_index,z_index) + avg_qrn(h_index,z_index) = wrf_dm_sum_real(avg_qrn(h_index,z_index)) / num_sample(h_index,z_index) + avg_qws(h_index,z_index) = wrf_dm_sum_real(avg_qws(h_index,z_index)) / num_sample(h_index,z_index) + avg_qds(h_index,z_index) = wrf_dm_sum_real(avg_qds(h_index,z_index)) / num_sample(h_index,z_index) + avg_qgr(h_index,z_index) = wrf_dm_sum_real(avg_qgr(h_index,z_index)) / num_sample(h_index,z_index) + end if + end do + end do + + !! calculate the contributions of each hydrometeor to total reflectivity and save them to hydro_mean.dat.update + hydro_weight_file='hydro_mean.dat.update' + if (rootproc) call da_get_unit(hydro_weight_unit) + if (rootproc) open(unit=hydro_weight_unit, file=trim(hydro_weight_file), form='FORMATTED') + if (rootproc) write(unit=hydro_weight_unit, fmt='(2(a8,2x), 4(a19,2x))') & + "z_index:", "h_index:", "===Rainwater===", "===Wet snow===", "===Dry snow===", "===Graupel===" + do z_index=1,tot_z_index + do h_index=1,tot_h_index + if (num_sample(h_index,z_index) .gt. 10.) then + if (avg_qrn(h_index,z_index) > 0.) & !! rain water + avg_zern(h_index,z_index) = zrn*(ave_rho(h_index,z_index)*avg_qrn(h_index,z_index))**1.75 + if (avg_qws(h_index,z_index) > 0.) & !! wet snow + avg_zews(h_index,z_index) = zws*(ave_rho(h_index,z_index)*avg_qws(h_index,z_index))**1.75 + if (avg_qds(h_index,z_index) > 0.) & !! dry snow + avg_zeds(h_index,z_index) = zds*(ave_rho(h_index,z_index)*avg_qds(h_index,z_index))**1.75 + if (avg_qgr(h_index,z_index) > 0.) & !! graupel + avg_zegr(h_index,z_index) = zgr*(ave_rho(h_index,z_index)*avg_qgr(h_index,z_index))**1.75 + end if + if (rootproc) & + write(unit=hydro_weight_unit, fmt='(2(i8, 2x), 4(f19.9,2x))') z_index, h_index, & + avg_zern(h_index,z_index),avg_zews(h_index,z_index), avg_zeds(h_index,z_index), avg_zegr(h_index,z_index) + end do + end do !bottom-top + if (rootproc) close(hydro_weight_unit) + if (rootproc) call da_get_unit(hydro_weight_unit) + end if !! use_radar_rhv .and. radar_rhv_opt == 2 + do n=iv%info(radar)%n1,iv%info(radar)%n2 if ( use_radar_rf .and. radar_rf_opt==1) then @@ -257,7 +399,6 @@ END IF dxm = iv%info(radar)%dxm(1,n) dym = iv%info(radar)%dym(1,n) - model_ps(n) = dxm *(dym * grid%xb % psac(i, j) + dy * grid%xb%psac(i+1, j)) + & dx *(dym * grid%xb % psac(i,j+1) + dy * grid%xb%psac(i+1,j+1)) + & grid%xb % ptop @@ -393,7 +534,7 @@ END IF end if end if - ! calculate background/model reflectivity + ! Calculate background/model reflectivity if (use_radar_rhv .or. use_radar_rqv) then if ( echo_rf_good ) then call da_radar_rf (model_qrn(k,n),model_qsn(k,n),model_qgr(k,n),model_tc(k,n),model_rho(k,n),bg_rze) @@ -403,8 +544,8 @@ END IF end if end if - ! calculate retrieved hydrometeorological variables - ! Jidong Gao JAS 2013 + ! Calculate retrieved hydrometeorological variables + ! Background-dependent retrieval scheme (Chen et al. 2020 AR; Chen et al. 2021 QJRMS) if (use_radar_rhv) then if ( echo_rf_good ) then @@ -431,48 +572,100 @@ END IF end if !if echo_non_precip end if - ob_radar_rf = min(ob_radar_rf, 55.0) ! if dBZ>55.0, set to 55.0 + ! The original WRFDA hydrometeor retrieval scheme + if (model_tc(k,n) .ge. 5.0) then + czrn = 1.0 + czws = 0.0 + czds = 0.0 + czgr = 0.0 + else if (model_tc(k,n) .ge. 0.0) then + czrn = (model_tc(k,n)+5.0)/10.0 + czws = (1.0-czrn)*zws/(zws+zgr) + czds = 0.0 + czgr = (1.0-czrn)*zgr/(zws+zgr) + else if (model_tc(k,n) .ge. -5.0) then + czrn = (model_tc(k,n)+5.0)/10.0 + czws = 0.0 + czds = (1.0-czrn)*zds/(zds+zgr) + czgr = (1.0-czrn)*zgr/(zds+zgr) + else if (model_tc(k,n) .lt. -5.0) then + czrn = 0.0 + czws = 0.0 + czds = zds/(zds+zgr) + czgr = zgr/(zds+zgr) + end if + + if (radar_rhv_opt == 2) then + ! backgound-dependent reflectivity retrival scheme (Chen et al. 2020, AR; Chen et al. 2021, QJRMS) + !! get the index of reflectvity + z_index = nint(ob_radar_rf/10.+1) + z_index = max(z_index, 0) + z_index = min(z_index, tot_z_index) + !! get the height index + h_index = nint(iv%radar(n)%height(k)/500.) + h_index = max(h_index, 1) + h_index = min(h_index, tot_h_index) + + if (z_index > 0) then + zern_ratio = avg_zern(h_index, z_index) + zews_ratio = avg_zews(h_index, z_index) + zeds_ratio = avg_zeds(h_index, z_index) + zegr_ratio = avg_zegr(h_index, z_index) + ! detect whether rain/snow/graupel exists in certain temperatures. + qg_exist = .true. + ! when T < 273.15K + if (model_tc(k,n) .lt. -5.0) zern_ratio = 0. + if (model_tc(k,n) .lt. 0.0) zews_ratio = 0. + ! when T >= 273.15K + if (model_tc(k,n) .ge. 0.0) then + zeds_ratio = 0. + qg_exist = .false. + do nk = k, iv%info(radar)%levels(n) + if (model_tc(nk,n) .lt. -5.0 .and. ob % radar(n) % rf(nk) .ge. 40.) qg_exist = .true. + end do + end if + if (model_tc(k,n) .ge. 5.0) zews_ratio = 0. + if (.not. qg_exist .or. model_tc(k,n) .ge. 10.0) zegr_ratio = 0. + + ! determine the contributions of each hydrometeor to reflectivity + if ((zern_ratio+zews_ratio+zeds_ratio+zegr_ratio) .gt. 0.) then + czrn = zern_ratio/(zern_ratio+zews_ratio+zeds_ratio+zegr_ratio) + czws = zews_ratio/(zern_ratio+zews_ratio+zeds_ratio+zegr_ratio) + czds = zeds_ratio/(zern_ratio+zews_ratio+zeds_ratio+zegr_ratio) + czgr = zegr_ratio/(zern_ratio+zews_ratio+zeds_ratio+zegr_ratio) + end if + else + ob_radar_rf = -15.0 !! Assign reflectivity below -5.0 dBZ to -15.0 dbZ for suppression + !! No need to tune the weights because of very small impacts + end if + end if + + ! convert dBZ to Z + ob_radar_rf = min(ob_radar_rf, 65.0) ! if dBZ>65.0, set to 65.0 rze = 10.0**(ob_radar_rf*0.1) ! dBZ to Z - if (model_tc(k,n).ge.5.0) then - ! contribution from rain only - ! Z_Qr = 3.63*1.0e9*(rho*Qr)**1.75 - iv % radar(n) % rrno(k) = exp ( log(rze/zrr)/1.75 )/model_rho(k,n) + ! Rainwater mixing ratio + if (czrn .gt. 0.) then + iv % radar(n) % rrno(k) = exp ( log(czrn*rze/zrn)/1.75 )/model_rho(k,n) iv % radar(n) % rrn(k) % qc = 0 + end if - ! rrn and rrno were assigned missing values in read_obs_radar_ascii.inc - ! maximum value check, use the data under threshold 15g/kg - iv % radar(n) % rrno(k) = min(iv%radar(n)%rrno(k), 0.015) - - else if (model_tc(k,n).lt.5.0 .and. model_tc(k,n).gt.-5.0 ) then - ! contribution from rain, snow and graupel - ! Ze = c * Z_Qr + (1-c) * (Z_Qs+Z_Qg) - ! the factor c varies linearly between 0 at t=-5C and 1 at t=5C - czr=(model_tc(k,n)+5)/10.0 - if (model_tc(k,n).le.0.0) then - czs = (1.0-czr)*zds/(zds+zg) ! dry snow - czg = (1.0-czr)*zg/(zds+zg) - iv % radar(n) % rsno(k) = exp ( log(czs*rze/zds)/1.75 )/model_rho(k,n) + ! Snow mixing ratio + if ((czws+czds) .gt. 0.) then + if (model_tc(k,n) .gt. 0.) then + iv % radar(n) % rsno(k) = exp ( log(czws*rze/zws)/1.75 )/model_rho(k,n) + iv % radar(n) % rsn(k) % qc = 0 else - czs = (1.0-czr)*zws/(zws+zg) ! wet snow - czg = (1.0-czr)*zg/(zws+zg) - iv % radar(n) % rsno(k) = exp ( log(czs*rze/zws)/1.75 )/model_rho(k,n) + iv % radar(n) % rsno(k) = exp ( log(czds*rze/zds)/1.75 )/model_rho(k,n) + iv % radar(n) % rsn(k) % qc = 0 end if - iv % radar(n) % rrno(k) = exp ( log(czr*rze/zrr)/1.75 )/model_rho(k,n) - iv % radar(n) % rgro(k) = exp ( log(czg*rze/zg )/1.75 )/model_rho(k,n) - iv % radar(n) % rrn(k) % qc = 0 - iv % radar(n) % rsn(k) % qc = 0 - iv % radar(n) % rgr(k) % qc = 0 + end if - else if (model_tc(k,n).le.-5.0) then - ! contribution from snow and graupel - czs = zds/(zds+zg) - czg = 1.0 - czs - iv % radar(n) % rsno(k) = exp ( log(czs*rze/zds)/1.75 )/model_rho(k,n) - iv % radar(n) % rgro(k) = exp ( log(czg*rze/zg )/1.75 )/model_rho(k,n) - iv % radar(n) % rsn(k) % qc = 0 + ! Graupel mixing ratio + if (czgr .gt. 0.) then + iv % radar(n) % rgro(k) = exp ( log(czgr*rze/zgr)/1.75 )/model_rho(k,n) iv % radar(n) % rgr(k) % qc = 0 - end if ! temp + end if if ( radar_rhv_err_opt == 1 ) then ! rainwater error @@ -643,6 +836,17 @@ END IF deallocate (model_qsn) deallocate (model_qgr) + if ( allocated(num_sample) ) deallocate (num_sample) + if ( allocated(avg_zern) ) deallocate (avg_zern) + if ( allocated(avg_zeds) ) deallocate (avg_zeds) + if ( allocated(avg_zews) ) deallocate (avg_zews) + if ( allocated(avg_zegr) ) deallocate (avg_zegr) + if ( allocated(avg_qrn) ) deallocate (avg_qrn) + if ( allocated(avg_qds) ) deallocate (avg_qds) + if ( allocated(avg_qws) ) deallocate (avg_qws) + if ( allocated(avg_qgr) ) deallocate (avg_qgr) + if ( allocated(ave_rho) ) deallocate (ave_rho) + if ( use_radar_rqv ) then deallocate (model_lcl) deallocate (model_qs_ice) diff --git a/var/da/da_radar/da_radar.f90 b/var/da/da_radar/da_radar.f90 index d971f6f604..507a5df0b8 100644 --- a/var/da/da_radar/da_radar.f90 +++ b/var/da/da_radar/da_radar.f90 @@ -1,20 +1,21 @@ module da_radar use module_domain, only : domain - + use module_dm, only : wrf_dm_sum_real use da_control, only : obs_qc_pointer,max_ob_levels,missing_r, & v_interp_p, v_interp_h, check_max_iv_print, trace_use, & missing, max_error_uv, max_error_t, rootproc, & max_error_p,max_error_q, check_max_iv_unit,check_max_iv, & max_stheight_diff,missing_data,max_error_bq,max_error_slp, & max_error_bt, max_error_buv, radar,fails_error_max, & - use_radar_rv, use_radar_rf,radar_rf_opt,radar_rf_rscl,radar_rv_rscl,rf_noice,rfmin, rf_qthres, use_radar_rhv, use_radar_rqv, & + use_radar_rv, use_radar_rf,radar_rf_opt,radar_rf_rscl,radar_rv_rscl,rf_noice,rfmin, rf_qthres, & + use_radar_rhv, use_radar_rqv, radar_rhv_opt,& below_model_surface,mkz,above_model_lid,& fg_format,fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional,fg_format_wrf_arw_global,& fg_format_kma_global,max_error_rv,max_error_rf, & far_below_model_surface,kms,kme,kts,kte, trace_use_dull,filename_len,& myproc, analysis_date, num_procs , ierr, comm, es_beta, es_gamma, a_ew - use da_control, only : its, ite, jts, jte, ids, ide, jds, jde, ims, ime, jms, jme + use da_control, only : its, ite, jts, jte, ids, ide, jds, jde, ims, ime, jms, jme, ips, ipe, jps, jpe, kds, kde use da_control, only : cloudbase_calc_opt, & radar_non_precip_rf, radar_non_precip_opt, radar_rqv_thresh1, radar_rqv_thresh2, & radar_rqv_rh1, radar_rqv_rh2, radar_non_precip_rh_w, radar_non_precip_rh_i, & diff --git a/var/da/da_radiance/da_allocate_rad_iv.inc b/var/da/da_radiance/da_allocate_rad_iv.inc index d5b5eb61ad..947498601b 100644 --- a/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/var/da/da_radiance/da_allocate_rad_iv.inc @@ -80,6 +80,10 @@ subroutine da_allocate_rad_iv (i, nchan, iv) end if if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) then allocate (iv%instid(i)%cloudflag(iv%instid(i)%num_rad)) + end if + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + allocate (iv%instid(i)%cloud_mod(nchan,iv%instid(i)%num_rad)) + allocate (iv%instid(i)%cloud_obs(nchan,iv%instid(i)%num_rad)) end if if ( index(iv%instid(i)%rttovid_string, 'gmi') > 0 ) then allocate (iv%instid(i)%clw(iv%instid(i)%num_rad)) @@ -112,16 +116,26 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate (iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) allocate (iv%instid(i)%cloud_frac(iv%instid(i)%num_rad)) if ( use_clddet_zz ) then - iv%instid(i)%superob_width = 2*ahi_superob_halfwidth+1 + ! here we assume AHI and ABI (they cover different regions) are not used simultaneously + if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) & + iv%instid(i)%superob_width = 2*ahi_superob_halfwidth+1 + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) & + iv%instid(i)%superob_width = 2*abi_superob_halfwidth+1 + allocate (iv%instid(i)%superob(iv%instid(i)%superob_width, & iv%instid(i)%superob_width)) do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width allocate (iv%instid(i)%superob(ix,iy)%cld_qc(iv%instid(i)%num_rad)) allocate (iv%instid(i)%superob(ix,iy)%tb_obs(nchan,iv%instid(i)%num_rad)) + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + do n = 1, iv%instid(i)%num_rad + allocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(nchan)) + end do + end if end do end do - end if + end if if ( use_rttov_kmatrix .or. use_crtm_kmatrix ) then allocate(iv%instid(i)%ts_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%ps_jacobian(nchan,iv%instid(i)%num_rad)) diff --git a/var/da/da_radiance/da_deallocate_radiance.inc b/var/da/da_radiance/da_deallocate_radiance.inc index e0e9f71b55..1ba3834654 100644 --- a/var/da/da_radiance/da_deallocate_radiance.inc +++ b/var/da/da_radiance/da_deallocate_radiance.inc @@ -38,6 +38,13 @@ deallocate ( satinfo(i) % clearSkyBias) endif + ! Deallocate extra variables for ABI + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + deallocate (satinfo(i) % error_cld_y) + deallocate (satinfo(i) % error_cld_x) + endif + + if (use_error_factor_rad) then deallocate (satinfo(i) % error_factor) endif @@ -115,6 +122,10 @@ end if if ( index(iv%instid(i)%rttovid_string, 'ahi') > 0 ) then deallocate (iv%instid(i)%cloudflag) + end if + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + deallocate (iv%instid(i)%cloud_mod) + deallocate (iv%instid(i)%cloud_obs) end if if ( index(iv%instid(i)%rttovid_string,'gmi') > 0 ) then deallocate (iv%instid(i)%clw) @@ -149,8 +160,16 @@ if ( use_clddet_zz ) then do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width - deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) - deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) + if ( index(iv%instid(i)%rttovid_string, 'abi') > 0 ) then + do n = 1,iv%instid(i)%num_rad + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3) + if ( allocated (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O_abi) ) & + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O_abi) + end do + end if + deallocate (iv%instid(i)%superob(ix,iy)%cld_qc) + deallocate (iv%instid(i)%superob(ix,iy)%tb_obs) end do end do deallocate (iv%instid(i)%superob) diff --git a/var/da/da_radiance/da_get_innov_vector_crtm.inc b/var/da/da_radiance/da_get_innov_vector_crtm.inc index d41260953d..17a8d4c635 100644 --- a/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -92,7 +92,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) real, allocatable :: hessian(:,:) real*8, allocatable :: eignvec(:,:), eignval(:) real :: rad_clr, rad_ovc_ilev, rad_ovc_jlev - + integer :: Band_Size(5), Bands(AIRS_Max_Channels,5) !For Zhuge and Zou cloud detection real, allocatable :: geoht_full(:,:,:) @@ -243,9 +243,10 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) calc_tb_clr = .false. if ( crtm_cloud .and. & ( trim( crtm_sensor_name(rtminit_sensor(inst))) == 'amsr2' .or. & + trim( crtm_sensor_name(rtminit_sensor(inst))) == 'abi' .or. & trim( crtm_sensor_name(rtminit_sensor(inst))) == 'ahi') ) then !Tb_clear_sky is only needed for symmetric obs error model - !symmetric obs error model only implemented for amsr2 for now + !symmetric obs error model only implemented for amsr2 & abi/ahi for now calc_tb_clr = .true. end if @@ -443,7 +444,6 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) end if - call da_interp_2d_partial (grid%xb%u10, iv%instid(inst)%info, 1, n, n, model_u10(n:n)) call da_interp_2d_partial (grid%xb%v10, iv%instid(inst)%info, 1, n, n, model_v10(n:n)) call da_interp_2d_partial (grid%xb%psfc, iv%instid(inst)%info, 1, n, n, model_psfc(n:n)) @@ -476,6 +476,14 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) cycle pixel_loop end if end do + !if ( all(ob%instid(inst)%tb(1:nchanl,n) < 0.) ) then + ! write(message(1),'(a,2i5.0,a)') ' Skipping the pixel at loc ', i, j, & + ! ' where all observed BTs are < 0' + ! call da_warning(__FILE__,__LINE__,message(1:1)) + ! iv%instid(inst)%tb_inv(:,n) = missing_r + ! iv%instid(inst)%info%proc_domain(:,n) = .false. + ! cycle pixel_loop + !end if ! convert cloud content unit from kg/kg to kg/m^2 if (crtm_cloud) then diff --git a/var/da/da_radiance/da_get_innov_vector_rttov.inc b/var/da/da_radiance/da_get_innov_vector_rttov.inc index ac78014a08..3f4dce9799 100644 --- a/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -49,12 +49,30 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) real, allocatable :: em_mspps(:) ! emissivity caluclated using MSPPS algorithm real :: ts_mspps ! surface temperature calcualted using MSPPS algorithm + !For Zhuge and Zou cloud detection + real, allocatable :: geoht_full(:,:,:) + real :: geoht_pixel(kts:min(kte,kme-1)) + real :: tt_pixel(kts:min(kte,kme-1)) + real :: pp_pixel(kts:min(kte,kme-1)) + if (trace_use) call da_trace_entry("da_get_innov_vector_rttov") !------------------------------------------------------ ! [1.0] calculate the background bright temperature !------------------------------------------------------- + if ( use_clddet_zz ) then + allocate ( geoht_full(ims:ime,jms:jme,kms:kme-1) ) + do k = kms, kme-1 + do j = jms, jme + do i = ims, ime + geoht_full(i,j,k) = 0.5 * ( grid%ph_2(i,j,k) + grid%phb(i,j,k) + & + grid%ph_2(i,j,k+1) + grid%phb(i,j,k+1) ) / gravity + end do + end do + end do + end if + do inst = 1, iv%num_inst ! loop for sensor if ( iv%instid(inst)%num_rad < 1 ) cycle nlevels = iv%instid(inst)%nlevels @@ -99,7 +117,6 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) call da_interp_lin_3d (grid%xb%t, iv%instid(inst)%info, iv%instid(inst)%t (:,n1:n2)) call da_interp_lin_3d (grid%xb%q, iv%instid(inst)%info, iv%instid(inst)%mr(:,n1:n2)) - do n= n1,n2 do k=1, nlevels if (iv%instid(inst)%info%zk(k,n) <= 0.0) then @@ -132,6 +149,19 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) iv%instid(inst)%surftype(n) = 0 end if + if ( use_clddet_zz ) then + ! Find tropopause temperature for Zhuge and Zou Cloud Detection + do k = kts, min(kte,kme-1) + call da_interp_2d_partial ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) + call da_interp_2d_partial ( grid%xb%p(:,:,k), iv%instid(inst)%info, k, n, n, pp_pixel(k) ) + call da_interp_2d_partial ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + +! call da_interp_lin_2d ( grid%xb%t(:,:,k), iv%instid(inst)%info, k, n, n, tt_pixel(k) ) +! call da_interp_lin_2d ( grid%xb%p(:,:,k), iv%instid(inst)%info, k, n, n, pp_pixel(k) ) +! call da_interp_lin_2d ( geoht_full(:,:,k), iv%instid(inst)%info, k, n, n, geoht_pixel(k) ) + end do + call da_trop_wmo ( tt_pixel, geoht_pixel, pp_pixel, (min(kte,kme-1)-kts+1), tropt = iv%instid(inst)%tropt(n) ) + end if end do call da_interp_lin_2d (grid%xb % u10, iv%instid(inst)%info, 1, iv%instid(inst)%u10(n1:n2)) @@ -381,6 +411,8 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) end do ! end loop for sensor + if ( use_clddet_zz ) deallocate ( geoht_full ) + if (trace_use) call da_trace_exit("da_get_innov_vector_rttov") #else call da_error(__FILE__,__LINE__, & diff --git a/var/da/da_radiance/da_get_sat_angles.inc b/var/da/da_radiance/da_get_sat_angles.inc new file mode 100644 index 0000000000..440d13e8f3 --- /dev/null +++ b/var/da/da_radiance/da_get_sat_angles.inc @@ -0,0 +1,100 @@ +subroutine da_get_sat_angles ( lat, lon, sate_index, satzen, satazi ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Menthod: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat,lon + integer, intent(in) :: sate_index + real, intent(out) :: satzen + real, optional, intent(out) :: satazi + + real(r_double) :: alat, alon, alon_sat + real(r_double) :: theta, r_tmp, theta_tmp, gam, beta + + satzen = missing_r + if ( present( satazi ) ) satazi = missing_r + + if ( lat .ge. 90. .or. & + lat .le. -90. .or. & + lon .gt. 180. .or. & + lon .lt. -180. ) then + return + end if + + if (sate_index .eq. 11) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 12) then + alon_sat = -60. * deg2rad + else if (sate_index .eq. 13) then + alon_sat = -75. * deg2rad + else if (sate_index .eq. 14) then + alon_sat = -105. * deg2rad + else if (sate_index .eq. 15) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 16) then +! alon_sat = -75.2 * deg2rad !True Value? + alon_sat = -75. * deg2rad !Nominal Value +! else if (sate_index .eq. 17) then +! alon_sat = -137. * deg2rad + else + write(*,*)'this satellite is not included' + stop + end if + + alat = lat * deg2rad + alon = lon * deg2rad + theta = alon-alon_sat + + ! Yang et al., 2017 + + ! zenith +! r_tmp = (2*earth_radius*sin(abs(theta)/2.)-earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 +! r_tmp = sqrt(r_tmp) +! satzen = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(satzen)/(satellite_height+earth_radius*(1-sin(satzen)))) +! satzen = (satzen+theta_tmp) / deg2rad !to degrees + + + ! Soler et al., Determination of Look Angles to Geostationary Communication Satellites, + ! Journal of Surveying Engineering, Vol. 120, No. 3, August, 1994. + ! follows spherical earth approximation + + ! zenith (up to 1 deg difference with code from Yang et al., 2017) + gam = acos( cos( alat ) * cos( abs( theta ) ) ) + r_tmp = ( satellite_height+earth_radius )**2 * & + ( 1.d0 + ( earth_radius / ( satellite_height+earth_radius ) )**2 - & + 2.d0 * ( earth_radius ) / ( satellite_height+earth_radius ) * cos(gam) ) + + if (r_tmp .lt. 0) return + + r_tmp = sqrt(r_tmp) + satzen = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) / deg2rad !to degrees + + + ! azimuth + if ( present(satazi) ) then + beta = tan(alat) / tan(gam) + if (beta.gt.1.D0 .and. beta.lt.1.00000001D0) beta = 1.0D0 + beta = acos( beta ) / deg2rad !to degrees + + if ( lat.lt.0. .and. theta.le.0. ) & + satazi = beta + if ( lat.ge.0. .and. theta.le.0. ) & + satazi = 180.d0 - beta + if ( lat.ge.0. .and. theta.gt.0. ) & + satazi = 180.d0 + beta + if ( lat.lt.0. .and. theta.gt.0. ) & + satazi = 360.d0 - beta + end if + + return + +end subroutine da_get_sat_angles diff --git a/var/da/da_radiance/da_get_sat_angles_1d.inc b/var/da/da_radiance/da_get_sat_angles_1d.inc new file mode 100644 index 0000000000..64b65d71cf --- /dev/null +++ b/var/da/da_radiance/da_get_sat_angles_1d.inc @@ -0,0 +1,132 @@ +subroutine da_get_sat_angles_1d ( lat, lon, sate_index, satzen, satazi ) +!------------------------------------------------- +! Purpose: calculate geostationary satellite_zenith_angle +! +! Method: Yang et al., 2017: Impact of assimilating GOES imager +! clear-sky radiance with a rapid refresh assimilation +! system for convection-permitting forecast over Mexico. +! J. Geophys. Res. Atmos., 122, 5472–5490 +!------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:),lon(:) + integer, intent(in) :: sate_index + real, intent(out) :: satzen(:) + real, optional, intent(out) :: satazi(:) + + integer :: n + real(r_double) :: alon_sat + real(r_double), allocatable :: alat(:), alon(:) + real(r_double), allocatable :: theta(:), r_tmp(:), theta_tmp(:), gam(:) + real(r_double), allocatable :: beta(:) + logical, allocatable :: valid_loc(:) + + satzen = missing_r + if (present(satazi)) satazi = missing_r + + n = size(lat) + if (n.le.0) return + + allocate( alat(n) ) + allocate( alon(n) ) + allocate( theta(n) ) + allocate( r_tmp(n) ) + allocate( theta_tmp(n) ) + allocate( gam(n) ) + allocate( valid_loc(n) ) + + !Define valid locations for vectorized operations + valid_loc = ( lat .lt. 90. .and. & + lat .gt. -90. .and. & + lon .le. 180. .and. & + lon .ge. -180. ) + + if (sate_index .eq. 11) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 12) then + alon_sat = -60. * deg2rad + else if (sate_index .eq. 13) then + alon_sat = -75. * deg2rad + else if (sate_index .eq. 14) then + alon_sat = -105. * deg2rad + else if (sate_index .eq. 15) then + alon_sat = -135. * deg2rad + else if (sate_index .eq. 16) then + alon_sat = -75.2 * deg2rad + else if (sate_index .eq. 17) then + alon_sat = -137.2 * deg2rad + else + write(*,*)'this satellite is not included' + stop + end if + + where ( valid_loc ) + alat = lat * deg2rad + alon = lon * deg2rad + theta = alon - alon_sat + elsewhere + alat = missing_r + alon = missing_r + theta = missing_r + gam = missing_r + r_tmp = missing_r + end where + + ! Yang et al., 2017 + ! zenith +! r_tmp = (2*earth_radius*sin(abs(theta)/2.)-earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 & +! +(2*earth_radius*sin(alat/2.))**2-(earth_radius*(1-cos(alat))*sin(abs(theta)/2.))**2 +! r_tmp = sqrt(r_tmp) +! satzen = 2*asin(r_tmp/earth_radius/2.) +! theta_tmp = atan(earth_radius*sin(satzen)/(satellite_height+earth_radius*(1-sin(satzen)))) +! satzen = (satzen+theta_tmp) / deg2rad !to degrees + + + ! Soler et al., Determination of Look Angles to Geostationary Communication Satellites, + ! Journal of Surveying Engineering, Vol. 120, No. 3, August, 1994. + ! follows spherical earth approximation + + ! zenith (up to 1 deg difference with code from Yang et al., 2017) + where ( valid_loc ) + gam = acos( cos( alat ) * cos( abs( theta ) ) ) + r_tmp = ( satellite_height+earth_radius )**2 * & + ( 1.d0 + ( earth_radius / ( satellite_height+earth_radius ) )**2 - & + 2.d0 * ( earth_radius ) / ( satellite_height+earth_radius ) * cos( gam ) ) + end where + + valid_loc = (valid_loc .and. r_tmp.ge.0) + + where ( valid_loc ) + r_tmp = sqrt(r_tmp) + satzen = asin((satellite_height+earth_radius) / r_tmp * sin(gam)) / deg2rad !to degrees + end where + + + ! azimuth + if ( present(satazi) ) then + allocate( beta(n) ) + beta = missing_r + where ( valid_loc ) & + beta = tan(alat) / tan(gam) + where ( beta.gt.1._r_double .and. & + beta.lt.1.00000001_r_double .and. valid_loc ) & + beta = 1.0_r_double + where ( valid_loc ) & + beta = acos( beta ) / deg2rad !to degrees + where ( lat.lt.0. .and. theta.le.0. .and. valid_loc ) & + satazi = beta + where ( lat.ge.0. .and. theta.le.0. .and. valid_loc ) & + satazi = 180.d0 - beta + where ( lat.ge.0. .and. theta.gt.0. .and. valid_loc ) & + satazi = 180.d0 + beta + where ( lat.lt.0. .and. theta.gt.0. .and. valid_loc ) & + satazi = 360.d0 - beta + deallocate( beta ) + end if + + deallocate( alat, alon, theta, r_tmp, theta_tmp, gam, valid_loc ) + + return + +end subroutine da_get_sat_angles_1d diff --git a/var/da/da_radiance/da_get_solar_angles.inc b/var/da/da_radiance/da_get_solar_angles.inc new file mode 100644 index 0000000000..0f1fc12b01 --- /dev/null +++ b/var/da/da_radiance/da_get_solar_angles.inc @@ -0,0 +1,215 @@ +subroutine da_get_solar_angles( yr, mt, dy, hr, mn, sc, & + lat, lon, solzen, solazi ) + !--------------------------------------------------------------------------------+ + ! This subroutine calculates the local azimuth and zenith angles of the sun at | + ! a specific location and time using an approximation to equations used | + ! to generate tables in The Astronomical Almanac. | + ! Refraction correction is added so sun position is apparent one. | + ! | + ! Michalsky, Joseph J., The Astronomical Almanac's algorithm for approximate | + ! solar position (1950-2050), Solar Energy, Vol. 40, No. 3, pp227-235, 1988. | + ! | + ! AND | + ! | + ! U.S. Gov't Printing Office, Washington,D.C. (1985). | + ! | + ! Provides solar zenith and azimuth angles with errors within ±0.01 deg. | + ! for the time period 1950-2050. | + ! | + ! INPUT parameters | + ! yr, mt, dy, hr, mn, sc = integer date/time quantities | + ! lat = latitude in degrees (north is positive) | + ! lon = longitude in degrees (east is positive) | + ! | + ! OUTPUT parameters | + ! solazi = sun azimuth angle (measured east from north, 0 to 360 degs) | + ! solzen = sun elevation angle (degs) | + ! | + ! Converted from F77 to F90 by Juan Pablo Justiniano | + ! (https://github.com/jpjustiniano/Subroutines) | + ! | + ! For more accurate algorithms (±0.0003 deg.) across longer periods of time, | + ! refer to the National Renewable Energy Laboratory (NREL) Solar Postion | + ! Algorithm (SPA), available in C, Matlab, and Python: | + ! - https://rredc.nrel.gov/solar/codesandalgorithms/spa | + ! - https://www.mathworks.com/matlabcentral/fileexchange/59903-nrel-s-solar-position-algorithm-spa | + ! - https://sunpy.org | + !--------------------------------------------------------------------------------+ + + implicit none + + integer, intent(in) :: yr, mt, dy, hr, mn, sc + real, intent(in) :: lat + real, intent(in) :: lon + real, intent(out) :: solazi + real, intent(out) :: solzen + + real(r_double) :: latrad + real(r_double) :: delta, ju, jmod, time, gmst, lmst + real(r_double) :: mnlon, mnanom, eclon, oblqec + real(r_double) :: num, den, ra, dec, ha + real(r_double) :: elev, refrac !, elc + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + +! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) +! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + + solzen = missing_r + solazi = missing_r + if ( lat .gt. 90. .or. & + lat .lt. -90. .or. & + lon .gt. 180. .or. & + lon .lt. -180. ) then + return + end if + + call da_get_julian_time( yr, mt, dy, hr, mn, jmod ) + ju = jmod / 1440.0 + real(sc,r_double) / 86400.0 + jd_jmod + + ! Calculate ecliptic coordinates (depends on time [days] since noon 1 Jan, 2000) + ! 51545.0 + 2.4e6 = noon 1 Jan, 2000 + time = ju - 51545.0 + + ! Force mean longitude between 0 and 360 degs + mnlon = 280.460 + 0.9856474 * time + mnlon = mod( mnlon, 360. ) + if ( mnlon.lt.0. ) mnlon = mnlon + 360. + + ! Mean anomaly in radians between 0 and 2*pi + mnanom = 357.528 + 0.9856003 * time + mnanom = mod( mnanom, 360. ) + if ( mnanom.lt.0. ) mnanom = mnanom + 360. + mnanom = mnanom * deg2rad + + ! Compute the ecliptic longitude and obliquity of ecliptic in radians + eclon = mnlon + 1.915*sin( mnanom ) + 0.020*sin( 2.*mnanom ) + eclon = mod( eclon, 360. ) + + if ( eclon.lt.0. ) eclon = eclon + 360. + + oblqec = 23.439 - 0.0000004*time + eclon = eclon * deg2rad + oblqec = oblqec * deg2rad + + ! Calculate right ascension and force between 0 and 2*pi + num = cos( oblqec ) * sin( eclon ) + den = cos( eclon ) + ra = atan( num/den ) + if ( den.lt.0 ) then + ra = ra + PI + elseif ( num.lt.0 ) then + ra = ra + 2.0*PI + endif + + ! Calculate declination in radians + ! (asin varies between -pi/2 to pi/2) + dec = asin( sin( oblqec ) * sin( eclon ) ) + + ! Calculate Greenwich mean sidereal time in hours +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_double) + real(mn,r_double) / 60. + real(sc,r_double) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_double) / 3600. + + ! Hour not changed to sidereal time since 'time' includes the fractional day + gmst = mod( gmst, 24. ) + if ( gmst.lt.0. ) gmst = gmst + 24. + + ! Calculate local mean sidereal time in radians + lmst = gmst + lon / 15. + lmst = mod( lmst, 24. ) + if ( lmst.lt.0. ) lmst = lmst + 24. + lmst = lmst * 15. * deg2rad + + + ! Calculate hour angle in radians between -pi and pi + ha = lmst - ra + if ( ha .lt. -PI ) ha = ha + 2.0*PI + if ( ha .gt. PI ) ha = ha - 2.0*PI + + ! Change latitude to radians + latrad = lat * deg2rad + + ! From this point on: + ! mnlon in degs, gmst in hours, ju in days minus 2.4e6; + ! mnanom, eclon, oblqec, ra, lmst, and ha in radians + + ! Calculate elevation (90 - zenith) + ! (asin varies between -pi/2 to pi/2) + elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + + ! Night-time angles are inconsequential + if ( elev < 0. ) return + + ! Calculate azimuth + ! (asin varies between -pi/2 to pi/2) + solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) + +!JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) +!! This puts azimuth between 0 and 2*pi radians +! if ( sin(dec) - sin(elev) * sin(latrad) .ge. 0. ) then +! if ( sin(solazi) .lt. 0. ) solazi = solazi + 2.0*PI +! else +! solazi = PI - solazi +! endif + + +! ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) +! JJG: elc is undefined when sin(dec) / sin(latrad) is outside [-1,1] or dec > latrad when both are positive...need better method to determine quadrant + !ORIGINAL: + !elc = asin( sin( dec ) / sin( latrad ) ) + !if ( elev.ge.elc ) solazi = PI - solazi + !if ( elev.le.elc .and. ha.gt.0. ) solazi = 2.0*PI + solazi + + !Updated according to Eq. 3.18 at https://www.powerfromthesun.net/Book/chapter03/chapter03.html + ! "Power From The Sun" is the great new website by William Stine and Michael Geyer. It features + ! a revised and updated (and free!) version of "Solar Energy Systems Design" by W.B.Stine and + ! R.W.Harrigan (John Wiley and Sons, Inc. 1986) retitled "Power From The Sun", along with + ! resources we hope you will find useful in learning about solar energy. + if ( cos(ha) < ( tan(dec) / tan(latrad) ) ) then + solazi = 2.0*PI + solazi + else + solazi = PI - solazi + end if + + ! Convert az to degs, force between 0 and 2*pi + solazi = solazi / deg2rad + solazi = mod( solazi, 360. ) + + ! Calculate refraction correction for US stan. atmosphere + ! (need to have elev in degs before calculating correction) + elev = elev / deg2rad + + !JJG: Added these bounds (should not need them) + !Keep elevation between -90. to +90. + if ( elev.lt.-90. ) & + elev = - (180. + elev) + if ( elev.gt.90. ) & + elev = 180. - elev + +! ! Michalsky (1988) +! if ( elev.gt. - 0.56 ) then +! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & +! ( 1. + 0.505*elev + 0.0845*elev**2 ) +! else +! refrac = 0.56 +! endif + + !J.P. Justiniano (not in Michalsky, more accurate than above?) + if ( elev.ge.19.225 ) then + refrac = 0.00452 * 3.51823 / tan( elev*deg2rad ) + else if ( elev.gt.-0.766 .and. elev.lt.19.225 ) then + refrac = 3.51579 * ( 0.1594 + 0.0196 * elev + 0.00002*elev**2 ) / & + ( 1. + 0.505*elev + 0.0845*elev**2 ) + else + refrac = 0.0 + end if + + ! note that 3.51579=1013.25 mb/288.2 C + + elev = elev + refrac + + ! Convert elevation to topocentric zenith + solzen = 90.0_r_kind - elev + +end subroutine da_get_solar_angles diff --git a/var/da/da_radiance/da_get_solar_angles_1d.inc b/var/da/da_radiance/da_get_solar_angles_1d.inc new file mode 100644 index 0000000000..aff7a519b5 --- /dev/null +++ b/var/da/da_radiance/da_get_solar_angles_1d.inc @@ -0,0 +1,253 @@ +subroutine da_get_solar_angles_1d( yr, mt, dy, hr, mn, sc, & + lat, lon, solzen, solazi ) + !--------------------------------------------------------------------------------+ + ! This subroutine calculates the local azimuth and zenith angles of the sun at | + ! a specific location and time using an approximation to equations used | + ! to generate tables in The Astronomical Almanac. | + ! Refraction correction is added so sun position is apparent one. | + ! | + ! Michalsky, Joseph J., The Astronomical Almanac's algorithm for approximate | + ! solar position (1950-2050), Solar Energy, Vol. 40, No. 3, pp227-235, 1988. | + ! | + ! AND | + ! | + ! U.S. Gov't Printing Office, Washington,D.C. (1985). | + ! | + ! Provides solar zenith and azimuth angles with errors within ±0.01 deg. | + ! for the time period 1950-2050. | + ! | + ! INPUT parameters | + ! yr, mt, dy, hr, mn, sc = integer date/time quantities | + ! lat = latitude in degrees (north is positive) | + ! lon = longitude in degrees (east is positive) | + ! | + ! OUTPUT parameters | + ! solazi = sun azimuth angle (measured east from north, 0 to 360 degs) | + ! solzen = sun elevation angle (degs) | + ! | + ! Converted from F77 to F90 by Juan Pablo Justiniano | + ! (https://github.com/jpjustiniano/Subroutines) | + ! | + ! For more accurate algorithms (±0.0003 deg.) across longer periods of time, | + ! refer to the National Renewable Energy Laboratory (NREL) Solar Postion | + ! Algorithm (SPA), available in C, Matlab, and Python: | + ! - https://rredc.nrel.gov/solar/codesandalgorithms/spa | + ! - https://www.mathworks.com/matlabcentral/fileexchange/59903-nrel-s-solar-position-algorithm-spa | + ! - https://sunpy.org | + !--------------------------------------------------------------------------------+ + + implicit none + + integer, intent(in) :: yr, mt, dy, hr, mn, sc + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + real, intent(out) :: solazi(:) + real, intent(out) :: solzen(:) + + real(r_double), allocatable :: latrad(:) + real(r_double) :: delta, ju, jmod, time, gmst + + real(r_double), allocatable :: lmst(:), ha(:) + real(r_double) :: mnlon, mnanom, eclon, oblqec + real(r_double) :: num, den, ra, dec + real(r_double), allocatable :: elev(:), refrac(:) !, elc(:) + logical, allocatable :: valid_loc(:) + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 43510.0 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + +! ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:00:00 (see da_get_julian_time) +! real(r_double), parameter :: jd_jmod = 43509.5 ! = 2443510.0 - 2.4e6 (rel. adjust improves precision of ±) + + + integer :: n + + n = size(lat) + allocate( latrad(n) ) + allocate( lmst(n) ) + allocate( ha(n) ) + allocate( elev(n) ) +! allocate( elc(n) ) + allocate( refrac(n) ) + allocate( valid_loc(n) ) + + call da_get_julian_time( yr, mt, dy, hr, mn, jmod ) + ju = jmod / 1440.0 + real(sc,r_double) / 86400.0 + jd_jmod + + ! Calculate ecliptic coordinates (depends on time [days] since noon 1 Jan, 2000) + ! 51545.0 + 2.4e6 = noon 1 Jan, 2000 + time = ju - 51545.0 + + ! Force mean longitude between 0 and 360 degs + mnlon = 280.460 + 0.9856474 * time + mnlon = mod( mnlon, 360. ) + if( mnlon.lt.0. ) mnlon = mnlon + 360. + + ! Mean anomaly in radians between 0 and 2*pi + mnanom = 357.528 + 0.9856003 * time + mnanom = mod( mnanom, 360. ) + if( mnanom.lt.0. ) mnanom = mnanom + 360. + mnanom = mnanom * deg2rad + + ! Compute the ecliptic longitude and obliquity of ecliptic in radians + eclon = mnlon + 1.915*sin( mnanom ) + 0.020*sin( 2.*mnanom ) + eclon = mod( eclon, 360. ) + + if ( eclon.lt.0. ) eclon = eclon + 360. + + oblqec = 23.439 - 0.0000004*time + eclon = eclon * deg2rad + oblqec = oblqec * deg2rad + + ! Calculate right ascension and force between 0 and 2*pi + num = cos( oblqec ) * sin( eclon ) + den = cos( eclon ) + ra = atan( num/den ) + if ( den.lt.0 ) then + ra = ra + PI + elseif ( num.lt.0 ) then + ra = ra + 2.0*PI + endif + + ! Calculate declination in radians + dec = asin( sin( oblqec ) * sin( eclon ) ) + + ! Calculate Greenwich mean sidereal time in hours +! gmst = 6.697375 + 0.0657098242*time + real(hr,r_double) + real(mn,r_double) / 60. + real(sc,r_double) / 3600. + gmst = 6.697375 + 0.0657098242*time + real(hr * 3600 + mn * 60 + sc, r_double) / 3600. + + ! Hour not changed to sidereal time since 'time' includes the fractional day + gmst = mod( gmst, 24. ) + if( gmst.lt.0. ) gmst = gmst + 24. + + !Define valid locations for vectorized operations + valid_loc = ( lat .le. 90. .and. & + lat .ge. -90. .and. & + lon .le. 180. .and. & + lon .ge. -180. ) + + ! Calculate local mean sidereal time in radians + where ( valid_loc ) + lmst = gmst + lon / 15. + lmst = mod( lmst, 24. ) + end where + where ( lmst.lt.0. .and. valid_loc ) + lmst = lmst + 24. + end where + where ( valid_loc ) + lmst = lmst * 15. * deg2rad + end where + + + ! Calculate hour angle in radians between -pi and pi + where ( valid_loc ) + ha = lmst - ra + end where + where ( ha .lt. -PI .and. valid_loc ) ha = ha + 2.0*PI + where ( ha .gt. PI .and. valid_loc ) ha = ha - 2.0*PI + + ! Change latitude to radians + latrad = missing_r + where ( valid_loc ) + latrad = lat * deg2rad + end where + + ! From this point on: + ! mnlon in degs, gmst in hours, jd in days if 2.4e6 added; + ! mnanom, eclon, oblqec, ra, lmst, and ha in radians + + ! Calculate elevation (90 - zenith) + ! (asin varies between -pi/2 to pi/2) + where ( valid_loc ) + elev = asin( sin( dec ) * sin( latrad ) + cos( dec ) * cos( latrad ) * cos( ha ) ) + end where + + ! Night-time angles are inconsequential + valid_loc = (valid_loc .and. elev.ge.0.) + + ! Calculate azimuth + ! (asin varies between -pi/2 to pi/2) + solazi = missing_r + where ( valid_loc ) + solazi = asin( -cos( dec ) * sin( ha ) / cos( elev ) ) + end where + +!JJG: From J.P. Justiniano (not in Michalsky, causes differences with NREL SPA) +!! This puts azimuth between 0 and 2*pi radians +! where ( sin(dec) - sin(elev) * sin(latrad) .ge. 0. ) then +! where ( sin(solazi) .lt. 0. ) solazi = solazi + 2.0*PI +! elsewhere +! solazi = PI - solazi +! endif + + ! When solazi=90 degs, elev == elcritical = asin( sin(dec) / sin(latrad) ) +! JJG: elc is undefined when sin(dec) / sin(latrad) is outside [-1,1] or dec > latrad when both are positive...need better method to determine quadrant + !where ( valid_loc ) + ! elc = asin( sin( dec ) / sin( latrad ) ) + !end where + !where ( elev.ge.elc .and. valid_loc ) solazi = PI - solazi + !where ( elev.le.elc .and. ha.gt.0. .and. valid_loc ) solazi = 2.0*PI + solazi + + !Updated according to Eq. 3.18 at https://www.powerfromthesun.net/Book/chapter03/chapter03.html + ! "Power From The Sun" is the great new website by William Stine and Michael Geyer. It features + ! a revised and updated (and free!) version of "Solar Energy Systems Design" by W.B.Stine and + ! R.W.Harrigan (John Wiley and Sons, Inc. 1986) retitled "Power From The Sun", along with + ! resources we hope you will find useful in learning about solar energy. + where ( valid_loc .and. cos(ha) < ( tan(dec) / tan(latrad) ) ) + solazi = 2.0*PI + solazi + elsewhere ( valid_loc ) + solazi = PI - solazi + end where + + ! Convert az to degs, force between 0 and 2*pi + where ( valid_loc ) + solazi = solazi / deg2rad + end where + solazi = mod( solazi, 360. ) + + ! Calculate refraction correction for US stan. atmosphere + ! (need to have elev in degs before calculating correction) + where ( valid_loc ) + elev = elev / deg2rad + end where + + !JJG: Added these bounds (should not need them) + !Keep elevation between -90. to +90. + where ( valid_loc .and. elev.lt.-90.) & + elev = - (180. + elev) + where ( valid_loc .and. elev.gt.90.) & + elev = 180. - elev + +! ! Michalsky (1988) +! where ( elev.gt. - 0.56 ) +! refrac = 3.51579 * ( 0.1594 + 0.0196*elev + 0.00002*elev**2 ) / & +! ( 1. + 0.505*elev + 0.0845*elev**2 ) +! elsewhere +! refrac = 0.56 +! end where + + !J.P. Justiniano (not in Michalsky, more accurate than above?) + where ( elev.ge.19.225 ) + refrac = 0.00452 * 3.51823 / tan( elev*deg2rad ) + elsewhere ( elev.gt.-0.766 .and. elev.lt.19.225 ) + refrac = 3.51579 * ( 0.1594 + 0.0196 * elev + 0.00002*elev**2 ) / & + ( 1. + 0.505*elev + 0.0845*elev**2 ) + elsewhere + refrac = 0.0 + end where + ! note that 3.51579=1013.25 mb/288.2 C + + where ( valid_loc ) + elev = elev + refrac + end where + + + ! Convert elevation to topocentric zenith + solzen = missing_r + where (valid_loc) + solzen = 90.0_r_kind - elev + end where + + deallocate( latrad, lmst, ha, elev, refrac, valid_loc ) + +end subroutine da_get_solar_angles_1d diff --git a/var/da/da_radiance/da_initialize_rad_iv.inc b/var/da/da_radiance/da_initialize_rad_iv.inc index 8c6de31102..4cc7740f33 100644 --- a/var/da/da_radiance/da_initialize_rad_iv.inc +++ b/var/da/da_radiance/da_initialize_rad_iv.inc @@ -93,6 +93,11 @@ subroutine da_initialize_rad_iv (i, n, iv, p) iv%instid(i)%tb_imp(:,n) = 0.0 iv%instid(i)%rad_xb(:,n) = 0.0 iv%instid(i)%rad_obs(:,n) = 0.0 + !if ( associated( p % rad_obs ) ) then + ! iv%instid(i)%rad_obs(:,n) = p%rad_obs(:) + !else + ! iv%instid(i)%rad_obs(:,n) = 0.0 + !end if iv%instid(i)%rad_ovc(:,:,n) = 0.0 iv%instid(i)%emiss(:,n) = 0.0 iv%instid(i)%scanpos(n) = p%scanpos @@ -113,14 +118,20 @@ subroutine da_initialize_rad_iv (i, n, iv, p) do iy = 1, iv%instid(i)%superob_width do ix = 1, iv%instid(i)%superob_width iv%instid(i)%superob(ix,iy)%tb_obs(:,n) = p % superob(ix,iy) % tb_obs(:,1) - iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT - iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT - iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR + if (index(iv%instid(i)%rttovid_string, 'abi') > 0) then + if ( allocated ( p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3 ) ) & + iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_3x3(:) = p % superob(ix,iy) % cld_qc(1) % tb_stddev_3x3(:) + end if + if (index(iv%instid(i)%rttovid_string, 'ahi') > 0) then iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_10 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_10 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_13 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_13 iv%instid(i)%superob(ix,iy)%cld_qc(n)%tb_stddev_14 = p % superob(ix,iy) % cld_qc(1) % tb_stddev_14 + end if + iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RTCT = p % superob(ix,iy) % cld_qc(1) % RTCT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%RFMFT = p % superob(ix,iy) % cld_qc(1) % RFMFT + iv%instid(i)%superob(ix,iy)%cld_qc(n)%TEMPIR = p % superob(ix,iy) % cld_qc(1) % TEMPIR iv%instid(i)%superob(ix,iy)%cld_qc(n)%terr_hgt = p % superob(ix,iy) % cld_qc(1) % terr_hgt - iv%instid(i)%superob(ix,iy)%cld_qc(n)%CIRH2O = p % superob(ix,iy) % cld_qc(1) % CIRH2O end do end do end if diff --git a/var/da/da_radiance/da_qc_goesabi.inc b/var/da/da_radiance/da_qc_goesabi.inc new file mode 100644 index 0000000000..ec860279e9 --- /dev/null +++ b/var/da/da_radiance/da_qc_goesabi.inc @@ -0,0 +1,706 @@ +subroutine da_qc_goesabi (it, isens, nchan, ob, iv) + + !--------------------------------------------------------------------------- + ! Purpose: perform quality control for abi data. + ! To be developed: built in cloud_detection method + !--------------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: it ! outer loop count + integer, intent(in) :: isens ! sensor index. + integer, intent(in) :: nchan ! number of channel + type (y_type), intent(in) :: ob ! Observation structure. + type (iv_type), intent(inout) :: iv ! O-B structure. + + ! local variables + logical :: lmix, cloud_detection + integer :: n,k,isflg,ios,fgat_rad_unit + integer :: ngood(nchan),nrej(nchan),nrej_omb_abs(nchan), & + nrej_omb_std(nchan),nrej_eccloud(nchan), & + nrej_clw(nchan),num_proc_domain, & + nrej_mixsurface,nrej_land + + ! isflg: SEA(0),ICE(1),LAND(2),SNOW(3),MSEA(4),MICE(5),MLND(6),MSNO(7) + integer, parameter :: sea_flag = 0 + integer, parameter :: ice_flag = 1 + integer, parameter :: land_flag = 2 + integer, parameter :: snow_flag = 3 + integer, parameter :: msea_flag = 4 + integer, parameter :: mice_flag = 5 + integer, parameter :: mland_flag = 6 + integer, parameter :: msnow_flag = 7 + +! ------- + real :: inv_grosscheck + + character(len=30) :: filename + + logical :: print_cld_debug + + !! Additional variables used by Harnish, Weissmann, & Perianez (2016) + real :: BTlim(nchan), cloud_mean(nchan) + real, allocatable :: cld_impact(:,:), cld_impact_global(:,:), weights_global(:) + integer :: buf_i, buf_f, nbuf, nlocal, nglobal, iproc + real, parameter :: camin = 0.0 !Harnisch et al. (2016) + !real, parameter :: camin = 0.5 !Okamoto et al. (2013) + + !! Additional variables used by Zhuge and Zou (2017) + integer :: itest + logical :: reject_clddet + real :: crit_clddet + real :: rad_O14, rad_M14, rad_tropt + real :: rad_o_ch7, rad_b_ch7, rad_o_ch14, rad_b_ch14 + real :: Relaz, Glintzen + real :: wave_num(10) + real :: plbc1(10), plbc2(10) + real :: plfk1(10), plfk2(10) + integer, parameter :: num_clddet_tests = 10 + integer, parameter :: num_clddet_cats = 4 + real :: eps_clddet(num_clddet_tests+2,num_clddet_cats) + integer :: index_clddet(num_clddet_tests), offset_clddet + integer :: isflgs_clddet(num_clddet_cats) + logical :: qual_clddet(num_clddet_cats) + character(len=10) :: crit_names_clddet(num_clddet_tests) + integer :: nrej_clddet(nchan,num_clddet_tests) + integer :: superob_center + integer*2 :: clddet_tests(iv%instid(isens)%superob_width, & + iv%instid(isens)%superob_width, & + num_clddet_tests) + integer :: isuper, jsuper + + real, pointer :: tb_obs(:,:), tb_xb(:,:), tb_inv(:,:), tb_xb_clr(:,:), & + cloud_obs(:,:), cloud_mod(:,:) + integer :: tb_qc(nchan) + + real :: big_num + + ! note: these values are constant across channels + real, parameter :: C1=1.19104276e-5 ! = 2 * h * c**2 mWm-2sr-1(cm-1)-4 + real, parameter :: C2=1.43877516 ! = h * c / b = 1.43877 K(cm-1)-1 + ! h = Planck's constant + ! b = Boltzmann constant + ! c = velocity of light + + integer, parameter :: ch7 = 1 + integer, parameter :: ch10 = 4 + integer, parameter :: ch14 = 8 + integer, parameter :: ch15 = 9 + + if (trace_use) call da_trace_entry("da_qc_goesabi") + +!! if (iv%instid(isens)%num_rad <= 0) return + + ! These values can change as SRF (spectral response function) is updated + ! It is recommended to acquire these from L1B files, not copy them from GOES R PUG L1b Vol. 3 + wave_num(1:10) = (/2570.373, 1620.528, 1443.554, 1363.228, 1184.220, & + 1040.891, 968.001, 894.000, 815.294, 753.790/) + plbc1(1:10) = (/0.43361, 1.55228, 0.34427, 0.05651, 0.18733, & + 0.09102, 0.07550, 0.22516, 0.21702, 0.06266/) + plbc2(1:10) = (/0.99939, 0.99667, 0.99918, 0.99986, 0.99948, & + 0.99971, 0.99975, 0.99920, 0.99916, 0.99974/) + + plfk1 = C1 * wave_num**3 + plfk2 = C2 * wave_num + + crit_names_clddet(1) = "rtct" + crit_names_clddet(2) = "etrop" + crit_names_clddet(3) = "pfmft" + crit_names_clddet(4) = "nfmft" + crit_names_clddet(5) = "rfmft" + crit_names_clddet(6) = "cirh2o" + crit_names_clddet(7) = "emiss4" + crit_names_clddet(8) = "ulst" + crit_names_clddet(9) = "notc" + crit_names_clddet(10) = "tempir" + + big_num = huge(big_num) + !! Table 4 from Zhuge X. and Zou X. JAMC, 2016. [modified from ABI Cloud Mask Algorithm] + !ocean land snow ice (assume same as snow) + eps_clddet = transpose( reshape( (/ & + 3.2, 4.1, big_num, big_num & + , 0.1, 0.3, 0.4, 0.4 & + , 0.8, 2.5, 1.0, 1.0 & + , 1.0, 2.0, 5.0, 5.0 & + , 0.7, 1.0, big_num, big_num & + , 0.7, 0.7, 0.7, 0.7 & + , 0.1, 0.46, 0.3, 0.3 & ! Land values: 0.46 in ABI CM; 0.2 in ZZ16 + , 2.86, big_num, big_num, big_num & + , 0.05, 0.1, 0.12, 0.12 & + , 15., 21., 10., 10. & + , 11., 15., 4.5, 4.5 & + , 2.0, 2.0, 2.0, 2.0 & + /), (/ size(eps_clddet, 2), size(eps_clddet, 1) /)) ) + index_clddet = (/1, 2, 3, 4, 5, 6, 7, 9, 10, 12/) + isflgs_clddet = (/sea_flag, land_flag, snow_flag, ice_flag/) + + + ngood(:) = 0 + nrej(:) = 0 + nrej_omb_abs(:) = 0 + nrej_omb_std(:) = 0 + nrej_eccloud(:) = 0 + nrej_clw(:) = 0 + nrej_mixsurface = 0 + nrej_land = 0 + num_proc_domain = 0 + + nrej_clddet = 0 + + tb_xb => iv%instid(isens)%tb_xb + tb_inv => iv%instid(isens)%tb_inv + +! print_cld_debug = .true. + print_cld_debug = .false. + + inv_grosscheck = 15.0 + if ( crtm_cloud ) inv_grosscheck = 80.0 + if ( use_satcv(2) ) inv_grosscheck = 100.0 + + if ( crtm_cloud ) then + tb_xb_clr => iv%instid(isens)%tb_xb_clr + + !JJG: for Harnisch et al. BTlim using stats from CONUS 9km 2-hr WRF forecast from GSI analysis + BTlim(1) = 269.5 +!3km 2/3 CONUS stats 01 MAY 2018 (mean) + BTlim(2) = 237.0 + BTlim(3) = 249.0 + BTlim(4) = 261.0 +!3km 2/3 CONUS stats 01 MAY 2018 (median) +! BTlim(2) = 231.5 +! BTlim(3) = 240.0 +! BTlim(4) = 250.5 + BTlim(5) = 271.0 + BTlim(6) = 258.0 + BTlim(7) = 272.0 + BTlim(8) = 268.0 + BTlim(9) = 270.5 + BTlim(10) = 258.0 + + cloud_obs => iv%instid(isens)%cloud_obs + cloud_obs = missing_r + + cloud_mod => iv%instid(isens)%cloud_mod + cloud_mod = missing_r + else + tb_xb_clr => iv%instid(isens)%tb_xb + end if + + superob_center = abi_superob_halfwidth + 1 + + ABIPixelQCLoop: do n= iv%instid(isens)%info%n1,iv%instid(isens)%info%n2 + tb_obs => ob%instid(isens)%tb + + if (iv%instid(isens)%info%proc_domain(1,n)) & + num_proc_domain = num_proc_domain + 1 + + ! 0.0 initialise QC by flags assuming good obs + !----------------------------------------------------------------- + tb_qc = qc_good + iv%instid(isens)%cloud_flag(:,n) = 0 + + ! 1.0 reject all channels over mixed surface type + !------------------------------------------------------ + isflg = iv%instid(isens)%isflg(n) + lmix = (isflg==msea_flag) .or. & + (isflg==mland_flag) .or. & + (isflg==msnow_flag) .or. & + (isflg==mice_flag) + + if (lmix) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_mixsurface = nrej_mixsurface + 1 + end if + + if ( isflg .ne. sea_flag ) then + do k = 1, nchan + if ( all(k .ne. (/ 2, 3, 4 /)) .and. only_sea_rad ) then + tb_qc(k) = qc_bad + nrej_land = nrej_land + 1 + end if + end do + end if + + ! 2.0 check iuse + !----------------------------------------------------------------- + where (satinfo(isens)%iuse(:) == -1) tb_qc = qc_bad + + ! 3.0 check cloud + !----------------------------------------------------------------- + if (.not. crtm_cloud ) then + if (iv%instid(isens)%clwp(n) >= 0.2) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_clw(:) = nrej_clw(:) + 1 + end if + + cloud_detection=.false. + if (cloud_detection) then + if (iv%instid(isens)%landsea_mask(n) == 0 ) then + if ( ( tb_xb(3,n) - tb_obs(3,n) ) > 3.5) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_eccloud(:) = nrej_eccloud(:) + 1 + end if + else + if ( ( tb_xb(3,n) - tb_obs(3,n) ) > 2.5) then + tb_qc = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_eccloud(:) = nrej_eccloud(:) + 1 + end if + end if + end if + end if + + abi_clddet: if ( use_clddet_zz ) then + + !!=============================================================================== + !!=============================================================================== + !! + !! 4.0 ABI IR-only Cloud Mask Algorithm, combines: + !! (*) Heidinger A. and Straka W., ABI Cloud Mask, version 3.0, 11 JUN, 2013. + !! (*) Zhuge X. and Zou X. JAMC, 2016. + !! + !!=============================================================================== + !!=============================================================================== + +!JJGDEBUG +! print_cld_debug = iv%instid(isens)%info%proc_domain(1,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG1: ', n, & + tb_inv(:,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG2: ', n, & + tb_xb_clr(:,n) + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG3: ', n, & + tb_obs(:,n) + if (crtm_cloud ) then + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F10.4:))') 'PIXEL_DEBUG4: ', n, & + tb_xb_clr(:,n) + end if + + if (print_cld_debug) write(stdout,'(A,I8,8F12.4,2x,A)') 'PIXEL_DEBUG5: ', n, & + iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & + iv%instid(isens)%satzen(n), iv%instid(isens)%satazi(n), & + iv%instid(isens)%solzen(n), iv%instid(isens)%solazi(n), & + iv%instid(isens)%tropt(n), iv%instid(isens)%superob(superob_center,superob_center)%cld_qc(n)%terr_hgt, & + iv%instid(isens)%info%date_char(n) +!JJGDEBUG + + + ! Assume tb_xb_clr (central pixel) is applicable to all super-obbed pixels + if (tb_xb_clr(ch7,n) > 0.) then + rad_b_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_xb_clr(ch7,n) ) ) - 1.0 ) + else + rad_b_ch7 = missing_r + end if + + if (tb_xb_clr(ch14,n) > 0.) then + rad_b_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_xb_clr(ch14,n) ) ) - 1.0 ) + else + rad_b_ch14 = missing_r + end if + + if ( tb_xb_clr(ch14,n) > 0. ) then + rad_M14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * tb_xb_clr(ch14,n)) ) - 1.0 ) + else + rad_M14 = missing_r + end if + if ( iv%instid(isens)%tropt(n) > 0. ) then + rad_tropt = plfk1(ch14) / & + ( exp( plfk2(ch14) / (plbc1(ch14) + plbc2(ch14) * iv%instid(isens)%tropt(n)) ) - 1.0 ) + else + rad_tropt = missing_r + end if + + clddet_tests = 0 + do jsuper = 1, iv%instid(isens)%superob_width + do isuper = 1, iv%instid(isens)%superob_width + ! Use tb_obs for this particular super-ob pixel + + tb_obs => iv%instid(isens)%superob(isuper,jsuper)%tb_obs + + if (tb_obs(ch7,n) > 0.) then + rad_o_ch7 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_obs(ch7,n) ) ) - 1.0 ) + else + rad_o_ch7 = missing_r + end if + if (tb_obs(ch14,n) > 0.) then + rad_o_ch14 = plfk1(ch7) / & + ( exp( plfk2(ch7) / ( plbc1(ch7) + plbc2(ch7) * tb_obs(ch14,n) ) ) - 1.0 ) + rad_O14 = plfk1(ch14) / & + ( exp( plfk2(ch14) / ( plbc1(ch14) + plbc2(ch14) * tb_obs(ch14,n) ) ) - 1.0 ) + else + rad_o_ch14 = missing_r + rad_O14 = missing_r + end if + + + ABICloudTestLoop: do itest = 1, num_clddet_tests + qual_clddet = .true. + offset_clddet = 0 + crit_clddet = missing_r + + select case (itest) + case (1) + !-------------------------------------------------------------------------- + ! 4.1 Relative Thermal Contrast Test (RTCT) + !-------------------------------------------------------------------------- + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%RTCT + qual_clddet(3:4) = .false. + + case (2) + !-------------------------------------------------------------------------- + ! 4.2 Cloud check: step 1 + ! Emissivity at Tropopause Test (ETROP) + !-------------------------------------------------------------------------- + if ( all((/rad_O14,rad_M14,rad_tropt/) > 0.0) ) & + crit_clddet = (rad_O14 - rad_M14) / (rad_tropt - rad_M14) + + case (3) + !-------------------------------------------------------------------------- + ! 4.3 Cloud check: step 2 + ! Positive Fourteen Minus Fifteen Test (PFMFT) + !-------------------------------------------------------------------------- + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = & + tb_xb_clr(ch14,n) > 0.0 .and. & + tb_xb_clr(ch15,n) > 0.0 .and. & + (tb_xb_clr(ch14,n) >= tb_xb_clr(ch15,n)) + + if ( (tb_obs(ch14,n)) <= 310. .and. & + iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) >= 0.3 .and. & + tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. ) & + crit_clddet = ( tb_obs(ch14,n) - tb_obs(ch15,n) ) +! above using ob without VarBC +! ------------------------------- +! crit_clddet = (tb_inv(ch14,n) + tb_xb_clr(ch14,n) - & +! (tb_inv(ch15,n) + tb_xb_clr(ch15,n)) ) +! above using ob with VarBC (requires clear-sky tb_inv) +! ------------------------------- + + if ( crit_clddet > missing_r .and. & + (tb_obs(ch14,n)) > 270. .and. & + tb_xb_clr(ch14,n) > 270. ) & + crit_clddet = crit_clddet - & + (tb_xb_clr(ch14,n) - tb_xb_clr(ch15,n)) * & + (tb_obs(ch14,n) - 260.) / (tb_xb_clr(ch14,n) - 260.) +! above 1 line using ob without VarBC +! (tb_inv(ch14,n) + tb_xb_clr(ch14,n) - 260.)/ & +! (tb_xb_clr(ch14,n) - 260.) +! above 2 lines using ob with VarBC (requires clear-sky tb_inv) + + case (4) + !-------------------------------------------------------------------------- + ! 4.4 Negative Fourteen Minus Fifteen Test (NFMFT) + !-------------------------------------------------------------------------- + if (tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. .and. & + tb_xb_clr(ch14,n) > 0. .and. tb_xb_clr(ch15,n) > 0. ) & + crit_clddet = (tb_xb_clr(ch14,n) - tb_xb_clr(ch15,n) ) & + - (tb_obs(ch14,n) - tb_obs(ch15,n)) + + case (5) + !-------------------------------------------------------------------------- + ! 4.5 Relative Fourteen Minus Fifteen Test (RFMFT) + !-------------------------------------------------------------------------- + ! See ABI Cloud Mask Description for qual_clddet + if (tb_obs(ch14,n) > 0. .and. tb_obs(ch15,n) > 0. ) then + qual_clddet = ( tb_obs(ch14,n) - tb_obs(ch15,n) ) < 1.0 + qual_clddet(2) = qual_clddet(2) .and. tb_obs(ch14,n) <= 300. + qual_clddet(3:4) = .false. + + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%RFMFT + end if + + case (6) + !-------------------------------------------------------------------------- + ! 4.6 Cirrus Water Vapor Test (CIRH2O) + !-------------------------------------------------------------------------- + ! See ABI Cloud Mask Description for qual_clddet + qual_clddet = & + iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%terr_hgt <= 2000. & + .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch10) > 0.5 & + .and. iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%tb_stddev_3x3(ch14) > 0.5 + + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%CIRH2O + + case (7) + !-------------------------------------------------------------------------- + ! 4.7 Modified 4um Emissivity Test (M-4EMISS) + !-------------------------------------------------------------------------- + ! Modify EMISS for sun glint area may be not work, because we are at north land + ! - compute relative azimuth + if ( all((/rad_o_ch7,rad_o_ch14,rad_b_ch7,rad_b_ch14/) > 0.0) ) & + crit_clddet = (rad_o_ch7/rad_o_ch14 - rad_b_ch7/rad_b_ch14) / & + (rad_b_ch7 / rad_b_ch14) + + if ( iv%instid(isens)%solzen(n) > 0. & + .and. iv%instid(isens)%solzen(n) < 90. ) then + Relaz = RELATIVE_AZIMUTH(iv%instid(isens)%solazi(n),iv%instid(isens)%satazi(n)) + + ! - compute glint angle + Glintzen = GLINT_ANGLE(iv%instid(isens)%solzen(n),iv%instid(isens)%satzen(n),Relaz ) + + if ( Glintzen < 40.0 .and. isflg==sea_flag) then + if (tb_xb_clr(ch7,n) > 0. .and. tb_obs(ch7,n) > 0.) then + crit_clddet = tb_xb_clr(ch7,n) - tb_obs(ch7,n) ! (B_ch7 - O_ch7) + else + crit_clddet = missing_r + endif + offset_clddet = 1 + end if + end if + + case (8) + !-------------------------------------------------------------------------- + ! 4.8 Uniform low stratus Test (ULST) + !-------------------------------------------------------------------------- +!JJG, AHI error: Changed this to solzen instead of solazi for night/day test + qual_clddet = iv%instid(isens)%solzen(n) >= 85.0 + if ( all((/rad_o_ch7,rad_o_ch14,rad_b_ch7,rad_b_ch14/) > 0.0) ) & + crit_clddet = rad_b_ch7/rad_b_ch14 - rad_o_ch7/rad_o_ch14 + + case (9) + !-------------------------------------------------------------------------- + ! 4.9 New Optically Thin Cloud Test (N-OTC) + !-------------------------------------------------------------------------- +!JJG, AHI error: Changed this to solzen instead of solazi for night/day test + if ( iv%instid(isens)%solzen(n) >= 85.0 ) & + offset_clddet = 1 ! night time + + if (tb_obs(ch7,n) > 0. .and. tb_obs(ch15,n) > 0.) & +! using ob without VarBC +! ------------------------------- + crit_clddet = tb_obs(ch7,n) - tb_obs(ch15,n) + +! using ob with VarBC (requires clear-sky tb_inv) +! ------------------------------- +! crit_clddet = tb_inv(ch7,n) + tb_xb_clr(ch7,n) - & +! (tb_inv(ch15,n) + tb_xb_clr(ch15,n)) + + case (10) + !-------------------------------------------------------------------------- + ! 4.10 Temporal Infrared Test (TEMPIR) + !-------------------------------------------------------------------------- + crit_clddet = iv%instid(isens)%superob(isuper,jsuper)%cld_qc(n)%TEMPIR + + case default + cycle ABICloudTestLoop + end select + +! call evaluate_clddet_test ( & +! isflg, isflgs_clddet, crit_clddet, eps_clddet(index_clddet(itest)+offset_clddet,:), qual_clddet, & +! iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n), & +! reject_clddet ) + + reject_clddet = crit_clddet > missing_r .and. & + any( isflg.eq.isflgs_clddet .and. & + crit_clddet > eps_clddet(index_clddet(itest)+offset_clddet,:) .and. & + qual_clddet ) + + if (reject_clddet) then + if (iv%instid(isens)%info%proc_domain(1,n)) then + nrej_clddet(:,itest) = nrej_clddet(:,itest) + 1 +!JJGDEBUG + if (print_cld_debug) write(stdout,"(A,F14.6,A,I4,2D12.4)") trim(crit_names_clddet(itest)), crit_clddet, " isflg", isflg, iv%instid(isens)%info%lat(1,n), iv%instid(isens)%info%lon(1,n) +!JJGDEBUG + end if + + clddet_tests(isuper, jsuper, itest) = 1 + end if + end do ABICloudTestLoop + end do ! isuper + end do ! jsuper + if ( iv%instid(isens)%superob_width > 1 ) then + iv%instid(isens)%cloud_frac(n) = & + real( count(sum(clddet_tests,3) > 0), 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) + end if + + ! cloud_flag = - round (mean number of tests failed) + iv%instid(isens)%cloud_flag(:,n) = & + - NINT( real( sum(clddet_tests) , 8 ) / real( iv%instid(isens)%superob_width**2, 8 ) ) + + if (.not. crtm_cloud .and. & + iv%instid(isens)%cloud_flag(1,n) < 0) then + tb_qc = qc_bad + end if + +!JJGDEBUG + if (print_cld_debug) write(stdout,'(A,I8,*(2x,I1:))') 'PIXEL_DEBUG6: ', n, clddet_tests(superob_center,superob_center,:) +!JJGDEBUG + end if abi_clddet + + tb_obs => ob%instid(isens)%tb + + ! --------------------------- + ! 5.0 assigning obs errors + if (.not. crtm_cloud ) then + if (use_error_factor_rad) then + iv%instid(isens)%tb_error(:,n) = & + satinfo(isens)%error_std(:) * satinfo(isens)%error_factor(:) + else + iv%instid(isens)%tb_error(:,n) = satinfo(isens)%error_std(:) + end if + else !crtm_cloud + ! calculate cloud impacts + where ( tb_inv( :, n ) > missing_r & + .and. tb_obs( :, n ) > 0. & + .and. tb_xb( :, n ) > 0. & + .and. BTlim( : ) > 0. & !Harnisch + ) +! .and. tb_xb_clr( :, n ) > 0. & !Okamoto or Guerrette + +! using ob with VarBC (tb_inv + tb_xb) +! ------------------------------- +!! Harnisch et al. (2016) + cloud_mod(:,n) = max( 0., BTlim(:) - tb_xb(:,n) ) + cloud_obs(:,n) = max( 0., BTlim(:) - (tb_inv(:,n) + tb_xb(:,n)) ) + +!! Okamoto et al. (2013) +! cloud_mod(:,n) = abs( tb_xb(:,n) - tb_xb_clr(:,n) ) + & +! cloud_obs(:,n) = abs( (tb_inv(:,n) + tb_xb(:,n)) - tb_xb_clr(:,n) ) +!!! J. Guerrette +! cloud_mod(:,n) = max( 0., tb_xb_clr(:,n) - tb_xb(:,n) ) + & +! cloud_obs(:,n) = max( 0., tb_xb_clr(:,n) - (tb_inv(:,n) + tb_xb(:,n)) ) + endwhere +!JJGDEBUG + if (print_cld_debug) write(stdout,'(A,I8,*(2x,F16.8))') 'PIXEL_DEBUG93: ', n, & + 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) +!JJGDEBUG + + if (abi_use_symm_obs_err) then + ! symmetric error model + ! - Okamoto, McNally, & Bell (2013) + ! - Harnish, Weissmann, & Perianez (2016) + + cloud_mean = 0.5 * ( cloud_mod(:,n) + cloud_obs(:,n) ) + + do k = 1, nchan + if ( cloud_mean(k) > missing_r ) then + if ( cloud_mean(k) < camin ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + else if ( cloud_mean(k) < satinfo(isens)%error_cld_x(k) ) then + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_std(k) + & + ( satinfo(isens)%error_cld_y(k) - satinfo(isens)%error_std(k) ) * & + ( cloud_mean(k) - camin ) / ( satinfo(isens)%error_cld_x(k) - camin ) + else + iv%instid(isens)%tb_error(k,n) = satinfo(isens)%error_cld_y(k) + end if + else + iv%instid(isens)%tb_error(k,n) = missing_r + end if + end do ! nchan + else + iv%instid(isens)%tb_error(1:nchan,n) = satinfo(isens)%error_std(1:nchan) + end if + end if + + ! 5.1 check obs and background + !----------------------------------------------------------------- + do k = 1, nchan + if (tb_obs(k,n) < 0.0) then + tb_qc(k) = qc_bad + end if + if (tb_xb(k,n) < 0.0) then + tb_qc(k) = qc_bad + end if + end do ! nchan + + + ! 5.2 check innovation + !----------------------------------------------------------------- + ! absolute departure check + do k = 1, nchan + if (abs(tb_inv(k,n)) > inv_grosscheck) then + tb_qc(k) = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_omb_abs(k) = nrej_omb_abs(k) + 1 + end if + end do ! nchan + + iv%instid(isens)%tb_qc(:,n) = tb_qc + + do k = 1, nchan + ! relative departure check + if (abs(tb_inv(k,n)) > 3.0 * iv%instid(isens)%tb_error(k,n)) then + iv%instid(isens)%tb_qc(k,n) = qc_bad + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej_omb_std(k) = nrej_omb_std(k) + 1 + end if + + ! final QC decsion + if (iv%instid(isens)%tb_qc(k,n) == qc_bad) then +! iv%instid(isens)%tb_error(k,n) = 500.0 + if (iv%instid(isens)%info%proc_domain(1,n)) & + nrej(k) = nrej(k) + 1 + else + if (iv%instid(isens)%info%proc_domain(1,n)) & + ngood(k) = ngood(k) + 1 + end if + end do ! nchan + end do ABIPixelQCLoop + + ! Do inter-processor communication to gather statistics. + call da_proc_sum_int (num_proc_domain) + call da_proc_sum_int (nrej_mixsurface) + call da_proc_sum_int (nrej_land) + call da_proc_sum_ints (nrej_eccloud) + + do itest = 1, num_clddet_tests + call da_proc_sum_ints (nrej_clddet(:,itest)) + end do + + call da_proc_sum_ints (nrej_omb_abs) + call da_proc_sum_ints (nrej_omb_std) + call da_proc_sum_ints (nrej_clw) + call da_proc_sum_ints (nrej) + call da_proc_sum_ints (ngood) + + if (rootproc) then + if (num_fgat_time > 1) then + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(isens)%rttovid_string)//'_',iv%time + else + write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(isens)%rttovid_string) + end if + + call da_get_unit(fgat_rad_unit) + open(fgat_rad_unit,file=trim(filename),form='formatted',iostat=ios) + if (ios /= 0) then + write(unit=message(1),fmt='(A,A)') 'error opening the output file ', filename + call da_error(__FILE__,__LINE__,message(1:1)) + end if + + write(fgat_rad_unit, fmt='(/a/)') ' Quality Control Statistics for '//iv%instid(isens)%rttovid_string + if(num_proc_domain > 0) write(fgat_rad_unit,'(a20,i7)') ' num_proc_domain = ', num_proc_domain + write(fgat_rad_unit,'(a20,i7)') ' nrej_mixsurface = ', nrej_mixsurface + write(fgat_rad_unit,'(a20,i7)') ' nrej_land = ', nrej_land + write(fgat_rad_unit,'(a20)') ' nrej_eccloud(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_eccloud(:) + write(fgat_rad_unit,'(a20)') ' nrej_clw(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_clw(:) + + do itest = 1, num_clddet_tests + write(fgat_rad_unit,'(3A)') ' nrej_',trim(crit_names_clddet(itest)),'(:) = ' + write(fgat_rad_unit,'(10i8)') nrej_clddet(:,itest) + end do + + write(fgat_rad_unit,'(a20)') ' nrej_omb_abs(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_omb_abs(:) + write(fgat_rad_unit,'(a20)') ' nrej_omb_std(:) = ' + write(fgat_rad_unit,'(10i7)') nrej_omb_std(:) + write(fgat_rad_unit,'(a20)') ' nrej(:) = ' + write(fgat_rad_unit,'(10i7)') nrej(:) + write(fgat_rad_unit,'(a20)') ' ngood(:) = ' + write(fgat_rad_unit,'(10i7)') ngood(:) + + close(fgat_rad_unit) + call da_free_unit(fgat_rad_unit) + end if + + if (trace_use) call da_trace_exit("da_qc_goesabi") + +end subroutine da_qc_goesabi + diff --git a/var/da/da_radiance/da_qc_rad.inc b/var/da/da_radiance/da_qc_rad.inc index 6a418fbbb8..2d320227ab 100644 --- a/var/da/da_radiance/da_qc_rad.inc +++ b/var/da/da_radiance/da_qc_rad.inc @@ -14,7 +14,7 @@ subroutine da_qc_rad (it, ob, iv) integer :: i, nchan,p,j logical :: amsua, amsub, hirs, msu,airs, hsb, ssmis, mhs, iasi, seviri - logical :: mwts, mwhs, atms, amsr2, imager, ahi, mwhs2, gmi + logical :: mwts, mwhs, atms, amsr2, imager, ahi, mwhs2, gmi, abi integer, allocatable :: index(:) integer :: num_tovs_avg @@ -66,6 +66,7 @@ subroutine da_qc_rad (it, ob, iv) amsr2 = trim(rttov_inst_name(rtminit_sensor(i))) == 'amsr2' imager = trim(rttov_inst_name(rtminit_sensor(i))) == 'imager' ahi = trim(rttov_inst_name(rtminit_sensor(i))) == 'ahi' + abi = trim(rttov_inst_name(rtminit_sensor(i))) == 'abi' gmi = trim(rttov_inst_name(rtminit_sensor(i))) == 'gmi' if (hirs) then ! 1.0 QC for HIRS @@ -104,6 +105,8 @@ subroutine da_qc_rad (it, ob, iv) call da_qc_ahi(it,i,nchan,ob,iv) else if (imager) then call da_qc_goesimg(it,i,nchan,ob,iv) + else if (abi) then + call da_qc_goesabi(it,i,nchan,ob,iv) else if (gmi) then call da_qc_gmi(it,i,nchan,ob,iv) else diff --git a/var/da/da_radiance/da_radiance.f90 b/var/da/da_radiance/da_radiance.f90 index 167d0480b5..cb1aa20d6b 100644 --- a/var/da/da_radiance/da_radiance.f90 +++ b/var/da/da_radiance/da_radiance.f90 @@ -11,6 +11,9 @@ module da_radiance #if defined(RTTOV) || defined(CRTM) use module_domain, only : xb_type, domain +#ifdef DM_PARALLEL + use module_dm, only : ntasks_x, ntasks_y +#endif use module_radiance, only : satinfo, & i_kind,r_kind, r_double, & one, zero, three,deg2rad,rad2deg, & @@ -58,6 +61,8 @@ module da_radiance use_rad,crtm_cloud, DT_cloud_model, global, use_varbc, freeze_varbc, & airs_warmest_fov, time_slots, interp_option, ids, ide, jds, jde, & ips, ipe, jps, jpe, simulated_rad_ngrid, obs_qc_pointer, use_blacklist_rad, use_satcv, & + use_goesabiobs, abi_superob_halfwidth, & + var4d, var4d_bin, & use_goesimgobs, pi, earth_radius, satellite_height,use_clddet_zz, ahi_superob_halfwidth, ahi_apply_clrsky_bias #ifdef CRTM @@ -88,7 +93,7 @@ module da_radiance use da_statistics, only : da_stats_calculate use da_tools, only : da_residual, da_obs_sfc_correction, & da_llxy, da_llxy_new, da_togrid_new, da_get_julian_time, da_get_time_slots, & - da_xyll, map_info + da_xyll, map_info, da_llxy_1d use da_tracing, only : da_trace_entry, da_trace_exit, da_trace, & da_trace_int_sort use da_varbc, only : da_varbc_direct,da_varbc_coldstart,da_varbc_precond, & @@ -129,6 +134,11 @@ module da_radiance #include "da_read_obs_netcdf4ahi_geocat.inc" #include "da_read_obs_netcdf4ahi_jaxa.inc" #include "da_read_obs_ncgoesimg.inc" +#include "da_read_obs_ncgoesabi.inc" +#include "da_get_sat_angles.inc" +#include "da_get_sat_angles_1d.inc" +#include "da_get_solar_angles.inc" +#include "da_get_solar_angles_1d.inc" #include "da_read_obs_hdf5gmi.inc" #include "da_get_satzen.inc" #include "da_allocate_rad_iv.inc" diff --git a/var/da/da_radiance/da_radiance1.f90 b/var/da/da_radiance/da_radiance1.f90 index e4690c086b..d53688d6a5 100644 --- a/var/da/da_radiance/da_radiance1.f90 +++ b/var/da/da_radiance/da_radiance1.f90 @@ -9,9 +9,11 @@ module da_radiance1 #ifdef CRTM use module_radiance, only : CRTM_Planck_Radiance, CRTM_Planck_Temperature #endif + use module_radiance, only : & #ifdef RTTOV - use module_radiance, only : coefs + coefs, & #endif + deg2rad use da_control, only : trace_use,missing_r, rootproc, & stdout,myproc,qc_good,num_fgat_time,qc_bad, & @@ -22,12 +24,16 @@ module da_radiance1 use_pseudo_rad, pi, t_triple, crtm_cloud, DT_cloud_model,write_jacobian, & use_crtm_kmatrix,use_clddet, use_satcv, cv_size_domain, & cv_size_domain_js, calc_weightfunc, deg_to_rad, rad_to_deg,use_clddet_zz, & - ahi_superob_halfwidth, ahi_use_symm_obs_err + ahi_superob_halfwidth, abi_superob_halfwidth, ahi_use_symm_obs_err, abi_use_symm_obs_err use da_define_structures, only : info_type,model_loc_type,maxmin_type, & iv_type, y_type, jo_type,bad_data_type,bad_data_type,number_type, & be_type, clddet_geoir_type, superob_type use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_integer - use da_par_util, only : da_proc_stats_combine +#ifdef DM_PARALLEL + use da_par_util, only : da_proc_stats_combine, true_mpi_real +#else + use da_par_util, only : da_proc_stats_combine +#endif use da_par_util1, only : da_proc_sum_int,da_proc_sum_ints use da_reporting, only : da_error, message use da_statistics, only : da_stats_calculate @@ -48,7 +54,7 @@ module da_radiance1 #endif implicit none - + type datalink_type type (info_type) :: info @@ -75,6 +81,7 @@ module da_radiance1 real, pointer :: tb_inv(:) real, pointer :: tb_qc(:) real, pointer :: tb_error(:) + real, pointer :: rad_obs(:) integer :: sensor_index type (datalink_type), pointer :: next ! pointer to next data end type datalink_type @@ -248,6 +255,7 @@ module da_radiance1 #include "da_qc_ahi.inc" #include "da_qc_gmi.inc" #include "da_qc_goesimg.inc" +#include "da_qc_goesabi.inc" #include "da_write_iv_rad_ascii.inc" #include "da_write_iv_rad_for_multi_inc.inc" #include "da_read_iv_rad_for_multi_inc.inc" diff --git a/var/da/da_radiance/da_radiance_init.inc b/var/da/da_radiance/da_radiance_init.inc index 3773b40122..63e471de9c 100644 --- a/var/da/da_radiance/da_radiance_init.inc +++ b/var/da/da_radiance/da_radiance_init.inc @@ -34,8 +34,9 @@ subroutine da_radiance_init(iv,ob) integer :: iunit character(len=filename_len) :: filename character(len=20) :: cdum + real :: error_cld_y, error_cld_x ! for ABI character(len=12) :: cdum12 - real :: error_cld + real :: error_cld ! for AMSR2 ! local variables for tuning error factor !---------------------------------------- @@ -152,6 +153,9 @@ subroutine da_radiance_init(iv,ob) else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'imgr' ) then nchanl(n) = 4 nscan(n) = 60 + else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'abi' ) then + nchanl(n) = 10 + nscan(n) = 22 else if ( trim( crtm_sensor_name(rtminit_sensor(n))) == 'gmi' ) then nchanl(n) = 13 nscan(n) = 221 @@ -204,6 +208,14 @@ subroutine da_radiance_init(iv,ob) allocate ( satinfo(n) % clearSkyBias(nchanl(n)) ) endif + ! Allocate additional fields for ABI + if ( index(iv%instid(n)%rttovid_string, 'abi') > 0 ) then + allocate ( satinfo(n) % error_cld_y(nchanl(n)) ) + allocate ( satinfo(n) % error_cld_x(nchanl(n)) ) + satinfo(n) % error_cld_y(:) = 500.0 !initialize + satinfo(n) % error_cld_x(:) = 5.0 !initialize + endif + read(iunit,*) do j = 1, nchanl(n) read(iunit,'(1x,5i5,2e18.10,a20)') & @@ -217,7 +229,7 @@ subroutine da_radiance_init(iv,ob) cdum !in the current radiance info files, the last column !can be either sensor_id_string or blank - if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then + if ( len_trim(cdum) > 0 .and. index(cdum,'-') == 0 ) then ! this is for AMSR2 ! read the line again to get error_cld when it is available backspace(iunit) read(iunit,'(1x,5i5,2e18.10,f10.5)') & @@ -228,10 +240,10 @@ subroutine da_radiance_init(iv,ob) idum, & satinfo(n)%error(j), & satinfo(n)%polar(j), & - error_cld - if ( error_cld > 0.0 ) then + error_cld + if ( error_cld > 0.0 ) then satinfo(n)%error_cld(j) = error_cld - end if + end if end if ! If AHI, read some extra things @@ -258,6 +270,30 @@ subroutine da_radiance_init(iv,ob) write(*,fmt='(i7,6x,4f9.3)') satinfo(n)%ichan(j), satinfo(n)%BTLim(j), satinfo(n)%ca1(j), satinfo(n)%ca2(j), satinfo(n)%clearSkyBias(j) endif + ! If ABI, read some extra things + ! Unfortunately, we need to read everything again... + if ( index(iv%instid(n)%rttovid_string, 'abi') > 0 ) then + backspace(iunit) + read(iunit,'(1x,5i5,2e18.10,2f10.5)') & + wmo_sensor_id, & + satinfo(n)%ichan(j), & + sensor_type, & + satinfo(n)%iuse(j) , & + idum, & + satinfo(n)%error(j), & + satinfo(n)%polar(j), & + error_cld_y, error_cld_x + if ( error_cld_y > 0.0 ) & + satinfo(n)%error_cld_y(j) = error_cld_y + if ( error_cld_x > 0.0 ) & + satinfo(n)%error_cld_x(j) = error_cld_x + if ( j == 1 ) then + write(*,*)'Reading extra data for ABI' + write(*,*)'Channel error_cld_y error_cld_x' + endif + write(*,fmt='(i7,6x,2f10.5)') satinfo(n)%ichan(j), satinfo(n)%error_cld_y(j), satinfo(n)%error_cld_x(j) + endif + iv%instid(n)%ichan(j) = satinfo(n)%ichan(j) ob%instid(n)%ichan(j) = satinfo(n)%ichan(j) end do diff --git a/var/da/da_radiance/da_read_obs_ncgoesabi.inc b/var/da/da_radiance/da_read_obs_ncgoesabi.inc new file mode 100644 index 0000000000..30ba8f994b --- /dev/null +++ b/var/da/da_radiance/da_read_obs_ncgoesabi.inc @@ -0,0 +1,2623 @@ +subroutine da_read_obs_ncgoesabi (iv, satellite_id) + + implicit none + +! 1.0 Read locs, parse, and select NC files: identify files for channels, views, times, overlap w/ patch/domain +!---------------------------------------------------------------------------------------------------------- +! 2.0 Read (BT) NC files: grab radiance data and convert to BT (K) +!---------------------------------------------------------------------------------------------------------- +! +! JJG: NEED TO ADD A MORE COMPLETE DESCRIPTION HERE +! + + !These libraries must be linked: netcdf, mpi + + !!These externally defined variables/routines are used herein: + ! cpp: DM_PARALLEL + ! PARALLELIZATION: ntasks_x, ntasks_y, num_procs, myproc, comm, ierr, true_mpi_real + ! RADIANCE OPERATOR: rtminit_nsensor, rtminit_platform, rtminit_sensor, rtminit_satid + ! THINNING: thinning_grid + ! GENERAL OBS: num_fgat_time, time_slots + ! WRFDA types: iv_type, datalink_type, info_type, model_loc_type + ! WRFDA subs: da_llxy, da_get_julian_time, + ! da_get_unit, da_free_unit, + ! da_get_sat_angles(_1d), da_get_solar_angles(_1d) + ! da_trace_entry, da_trace_exit, + ! precisions: r_double, i_kind + + type (iv_type),intent (inout) :: iv + integer, intent(in) :: satellite_id ! 16 or 17 + + type(datalink_type), pointer :: head, p, current, prev, p_fgat + type(info_type) :: info + type(model_loc_type) :: loc + integer(i_kind), allocatable :: ptotal(:) + integer(i_kind) :: nthinned + real(r_double) :: crit + integer(i_kind) :: iout, iobs, i_dummy(1) + logical :: outside, outside_all, iuse, first_chan + logical :: found, head_found + + !! ABI Fixed Grid Variables + integer :: ny_global, nx_global + integer :: yoff_fd, xoff_fd + ! For MPI parallelization + integer :: nbuf, nrad_local, nrad_mask, buf_i, buf_f + integer, allocatable :: nbufs(:), displs(:) + integer :: ny_local, nx_local + + !! Earth location info + real, allocatable :: yy_abi(:), xx_abi(:) + real, allocatable :: yy_1d(:), xx_1d(:) + real, allocatable :: iy_1d(:), ix_1d(:) + real, allocatable :: solzen_1d(:), solazi_1d(:) + + real(r_double) :: req, rpol, pph, nam +!!! real :: lat_sat, lon_sat ! Assume fixed values in da_get_sat_angles + real, allocatable, target :: buf_real(:,:) + integer, allocatable, target :: buf_int(:,:) + type(model_loc_type), allocatable, target :: buf_loc(:) + type(info_type), allocatable :: info_1d(:) + + + ! Masks for data reduction + logical :: earthmask, zenmask + logical, allocatable :: & + earthmask_1d(:) , & + zenmask_1d(:) , & + domainmask_1d(:) , & + patchmask_1d(:) , & + dummybool_2d(:,:) , & + allmask_p(:,:) , & + readmask_p(:,:) , & + thinmask(:,:) + + logical, allocatable :: view_mask(:,:,:,:,:) + + logical :: use_view_mask, best_view + + + ! Brightness Temperature (K) + real, allocatable :: bt_p(:,:,:), rad_p(:,:,:), terrain_hgt(:,:) + real :: bc1, bc2, fk1, fk2 + + !! Iterates + integer :: ichan, ifile, iview, ifgat, ipass, ioff, & + jchan, jfile, jview, icount, io_stat, & + n, i, j, iy, ix, jy, jx, iyl, ixl, iyfd, ixfd, iproc, subgrid, & + isup, jsup, ixsup, iysup + INTEGER :: cstat, estat + CHARACTER(LEN=100) :: cmsg + logical :: exists + + !! Satellite variables + integer(i_kind),parameter :: nchan = 10 + integer(i_kind),parameter :: nscan = 22 + integer, parameter :: platform_id = 4 ! GOES series + integer, parameter :: sensor_id = 44 ! ABI + integer, parameter :: channel_list(nchan) = (/7,8,9,10,11,12,13,14,15,16/) !List of all available channels +! integer, parameter :: channel_index(channel_list(1):channel_list(nchan)) = (/1,2,3,4,5,6,7,8,9,10/) !List of all available channels + + integer, parameter :: nviews = 4 + integer(i_kind) :: inst + character(len=14), parameter :: INST_PREFIX = 'OR_ABI-L1b-Rad' + + !! File reading variables + character(len=1000) :: fname, command + character(len=50) :: list_file + integer :: file_unit + + type date_type + integer :: yr, mt, dy, hr, mn, sc, jdy + real(r_double) :: obs_time + end type date_type + +! ! Linked list type for radiance location information +! type viewnode +! real :: lat, lon, satzen, satazi +! integer :: iy, ix +! type(model_loc_type) :: loc +! type(viewnode), pointer :: next +! integer :: i +! end type viewnode + + type field_r + real, pointer :: local(:) + real, pointer :: domain(:) + real, pointer :: patch(:) + end type field_r + type field_i + integer, pointer :: local(:) + integer, pointer :: domain(:) + integer, pointer :: patch(:) + end type field_i + type field_loc + type(model_loc_type), pointer :: local(:) + type(model_loc_type), pointer :: domain(:) + type(model_loc_type), pointer :: patch(:) + end type field_loc + + type viewinfo + logical :: select + integer :: nfiles + character(len=1000) :: fpath + character(len=200), allocatable :: filename(:) + integer, allocatable :: filechan(:) + type(date_type), allocatable :: filedate(:) + logical, allocatable :: file_fgat_match(:,:) + real*8, allocatable :: fgat_time_abs_diff(:,:) ! seconds + real*8, allocatable :: min_time_diff(:,:) ! seconds + integer, allocatable :: nfiles_used(:) + logical :: meta_initialized = .false. + logical :: grid_initialized = .false. + integer :: ny_global, nx_global, yoff_fd, xoff_fd + integer :: ys_local, xs_local + integer :: ye_local, xe_local + integer, allocatable :: ny_grid(:), nx_grid(:) + integer, allocatable :: ys_grid(:), xs_grid(:) + integer :: ys_p, xs_p + integer :: ye_p, xe_p + integer :: ys_p_fd, xs_p_fd + integer :: ye_p_fd, xe_p_fd + integer :: nrad_on_patch, nrad_on_domain + integer :: nrad_on_patch_cldqc, nrad_on_domain_cldqc + logical, allocatable :: patchmask(:,:,:) +! type(viewnode), pointer :: head +! type(viewnode), pointer :: current + + type(field_r) :: lat_1d, lon_1d, satzen_1d, satazi_1d + type(field_i) :: iy_1d, ix_1d + type(field_loc) :: loc_1d + + character(len=2) :: name_short + character(len=10) :: name + logical :: moving + end type viewinfo + + type(viewinfo), target, allocatable :: view_att(:) + type(viewinfo), pointer :: this_view + + integer :: first_file, tot_files_used, npass + integer :: ncid, varid + + !! WRFDA channel and satellite_id select + !! These should be inputs to the subroutine or global variables in WRFDA + !Could populate using .info file. Would reduce number of files to read... +! integer, dimension(10) :: channel_select = (/7, 8, 9, 10, 11, 12, 13, 14, 15, 16/) + + ! Global WRFDA obs timing info + character(len=19) :: fgat_times_c(num_fgat_time) + real(r_double) :: fgat_times_r(num_fgat_time) + + ! Local Obs date/time variables + real(r_double) :: obs_time + integer(i_kind) :: yr, mt, dy, hr, mn, sc, jdy + real(r_double) :: timbdy(2) + + ! Other work variables + real(r_double) :: dlon_earth,dlat_earth,dlon_earth_deg,dlat_earth_deg + real(r_double) :: ngoes + integer(i_kind) :: num_goesabi_local, num_goesabi_global, & + num_goesabi_used, num_goesabi_used_fgat(num_fgat_time), & + num_goesabi_used_tmp, num_goesabi_thinned + integer(i_kind) :: itx, itt + real, allocatable :: in(:), out(:) + + !Cloud QC variables + integer :: tbuf, nkeep, ikeep + integer :: abi_halo_width ! Must be ≥ 0 + integer :: superob_width + real :: mu10, mu14, sigma10, sigma14, pearson, temp_max + real :: mu, sigma + real, allocatable :: tb_temp(:,:) + logical :: cldqc + character(18) :: terr_fname + + integer :: TEMPIR_ifile + real :: TEMPIR_min_time_diff, TEMPIR_time_abs_diff + real, parameter :: TEMPIR_delay_minutes = 15.0 + + if (trace_use) call da_trace_entry("da_read_obs_ncgoesabi") + +! determine if satellite_id is supported +!----------------------------------------------------- + if(satellite_id .ne. 16 .and. & + satellite_id .ne. 17) then + write(unit=stdout,fmt='(A,I2.2,A)') 'goes satellite ', satellite_id, ' is not supported for abi instrument' + return + endif + + write(terr_fname,'(A,I2.2,A)') 'OR_ABI-TERR_G',satellite_id,'.nc' + +! determine if sensor triplet is in the sensor list +!----------------------------------------------------- + inst = 0 + do ngoes = 1, rtminit_nsensor + if (platform_id == rtminit_platform(ngoes) & + .and. sensor_id == rtminit_sensor(ngoes) & + .and. satellite_id == rtminit_satid(ngoes)) then + inst = ngoes + else + cycle + end if + end do + if (inst == 0) then + write(unit=message(1),fmt='(A,I2.2,A)') " goes-",satellite_id,"-abi is not in sensor list" + call da_warning(__FILE__,__LINE__, message(1:1)) + return + end if + + allocate(ptotal(0:num_fgat_time)) + ptotal(0:num_fgat_time) = 0 + iobs = 0 ! for thinning, argument is inout + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Initialize ABI L1B reading + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ifgat=1,num_fgat_time + if (num_fgat_time.eq.1 .or. (ifgat.gt.1 .and. ifgat.lt.num_fgat_time)) then + fgat_times_r(ifgat) = & + (time_slots(ifgat) + time_slots(ifgat-1)) / 2.D0 !minutes + else if (ifgat .eq. 1) then !First time slot is dt/2 (da_get_time_slots) + fgat_times_r(ifgat) = & + time_slots(ifgat-1) !minutes + else !Last time slot is dt/2 (da_get_time_slots) + fgat_times_r(ifgat) = & + time_slots(ifgat) !minutes + end if + + call da_get_cal_time(fgat_times_r(ifgat),yr,mt,dy,hr,mn,sc) + fgat_times_r(ifgat) = fgat_times_r(ifgat) * 60.D0 !seconds + + write(unit=fgat_times_c(ifgat), & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + end do + + allocate(view_att(nviews)) + ! (default) All views are used (algorithm figures out which views have files present) + ! Could set this according to namelist entries + view_att(:) % select = .true. + view_att(1) % name_short = 'F' + view_att(2) % name_short = 'C' + view_att(3) % name_short = 'M1' + view_att(4) % name_short = 'M2' + + view_att(1) % name = 'Full Disk' + view_att(2) % name = 'CONUS' + view_att(3) % name = 'MESO1' + view_att(4) % name = 'MESO2' + + write(view_att(1) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-fdisk*/" + write(view_att(2) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-conus*/" + write(view_att(3) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-meso*/" + write(view_att(4) % fpath,'(A,I2.2,A)') "./goes-",satellite_id,"-meso*/" + + ! (default) Full Disk and CONUS are fixed while MESO 1 & 2 can move within an assimilation window + view_att(1) % moving = .false. + view_att(2) % moving = .false. + view_att(3) % moving = .true. + view_att(4) % moving = .true. + +! ! Full Disk, CONUS, and MESO 1 & 2 are fixed within an assimilation window (e.g., 3D-Var) +! view_att(1) % moving = .false. +! view_att(2) % moving = .false. +! view_att(3) % moving = .false. +! view_att(4) % moving = .false. + + !! Initialize local obs structures + allocate (head) + nullify (head % next ) + p => head + + num_goesabi_local = 0 + num_goesabi_global = 0 + num_goesabi_used_fgat = 0 + num_goesabi_thinned = 0 + + abi_halo_width = abi_superob_halfwidth + if ( use_clddet_zz ) then + abi_halo_width = abi_halo_width + 10 + end if + + superob_width = 2*abi_superob_halfwidth+1 + + tot_files_used = 0 + use_view_mask = .false. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Collect files available for all views + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + PrepViews: do iview = 1, nviews + this_view => view_att(iview) + + if ( .not.this_view % select ) cycle PrepViews + + ! Query fpath for files that match L1B naming conventions for this_view and satellite_id + fname = trim(INST_PREFIX)//trim(this_view % name_short) + write(list_file,'(A,I2.2,2A)') & + 'file_list_GOES-',satellite_id,'-ABI_',trim(this_view % name_short) + + call da_get_unit(file_unit) + + if (rootproc) then + inquire(file=trim(list_file), exist=exists) + if ( .not.exists ) then + ! Create list_file containing all files for this_view + write(unit=stdout,fmt='(5A)') 'Searching for GOES ', trim(this_view % name) ,' files in ', trim(this_view % fpath),'...' + + write(command,fmt='(5A,I2.2,2A)')& + "find ",trim(this_view % fpath), & + " \( -type l -o -type f \) -name '",trim(fname), & + "*G",satellite_id, & + "*' > ",trim(list_file) +! "*' -printf '%P\n' > ",trim(list_file) + + write(stdout,fmt='(A)') 'WARNING find requires substantial memory. It is recommended to issue' + write(stdout,fmt='(A)') 'WARNING the following from the command line before running WRFDA:' + write(stdout,fmt='(A)') adjustl(trim(command)) + cmsg = "" + call execute_command_line ( adjustl(trim(command)), & + WAIT=.true., EXITSTAT=estat, CMDSTAT=cstat, CMDMSG=cmsg ) + write(stdout,*) 'estat: ', estat + write(stdout,*) 'cstat: ', cstat + write(stdout,*) 'cmsg: ', cmsg + end if + write(unit=stdout,fmt='(5A)') 'Using GOES ', trim(this_view % name) ,' files listed in ', trim(list_file) + + icount = 0 + io_stat = -1 + do while (io_stat .ne. 0) + open(unit=file_unit,file=trim(list_file), iostat = io_stat) + icount = icount + 1 + if (icount .gt. 10000) exit + end do + + this_view % nfiles = 0 + do + read(file_unit, fmt=*, iostat = io_stat) + if ( io_stat .ne. 0 ) exit + this_view % nfiles = this_view % nfiles + 1 + end do + close(file_unit) + + i_dummy = this_view % nfiles + end if +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) + call mpi_bcast ( i_dummy(1), 1, mpi_integer, root, comm, ierr ) + this_view % nfiles = i_dummy(1) +#endif + if (this_view % nfiles .lt. 1) then + this_view % select = .false. + cycle PrepViews + end if + + allocate(this_view % filename(this_view % nfiles)) + + ! Read the file names for this view + open(unit=file_unit,file=trim(list_file)) + read(file_unit, fmt='(A)') (this_view % filename(ifile), ifile=1,this_view % nfiles) + close(file_unit) + + call da_free_unit(file_unit) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Allocate/init components for this_view + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(this_view % filechan(this_view % nfiles)) + allocate(this_view % filedate(this_view % nfiles)) + allocate(this_view % file_fgat_match(this_view % nfiles,num_fgat_time)) + allocate(this_view % fgat_time_abs_diff(this_view % nfiles,num_fgat_time)) + allocate(this_view % min_time_diff(nchan,num_fgat_time)) + allocate(this_view % nfiles_used(num_fgat_time)) + + this_view % file_fgat_match = .false. + do ifgat=1,num_fgat_time + this_view % fgat_time_abs_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 !seconds + + this_view % min_time_diff(:,ifgat) = & + abs(time_slots(ifgat) - time_slots(ifgat-1)) * 60.D0 / 2.D0 !seconds + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which of the files will be used based on user-definitions: + !! + fgat window length + !! + channels used + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ifile = 1, this_view % nfiles + + !Grab the filename (without path) using INST_PREFIX + fname = trim(this_view % filename(ifile)) + ioff = index(fname, trim(INST_PREFIX)) +!! this_view % filepath(ifile) = fname(1:ioff-1) + fname = trim(fname(ioff:len(adjustl(trim(fname))))) +!! this_view % filename(ifile) = trim(fname) + + ioff = 0 + if (iview.eq.3 .or. iview.eq.4) ioff=1 + ioff = ioff+19 + read(fname(1+ioff:2+ioff),fmt='(I2.2)') this_view % filechan(ifile) + +!!! !! The channel could instead be read from band_id in each file, but +!!! !! opening/closing files for all channels is time consuming +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'band_id',varid) +!!! ierr=nf_get_var_int(ncid,varid,this_view % filechan(ifile)) +!!! ierr=nf_close(ncid) + + ! Check if channel is selected +! if ( .not.any(this_view % filechan(ifile) .eq. channel_select) .or. & + if ( .not.any(this_view % filechan(ifile) .eq. channel_list) ) then +!!! ierr=nf_close(ncid) + cycle + end if + + !! Determine central date of this file for obs binning + !obs START time + ioff = ioff + 8 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = real(sc,8)/60.D0 / 2.D0 + + call jday2cal(jdy, yr, mt, dy) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(1)) + + this_view % filedate(ifile) % jdy = jdy + + !obs END time + ioff = ioff + 16 + read(fname(1+ioff:4+ioff),fmt='(I4.4)') yr + read(fname(5+ioff:7+ioff),fmt='(I3.3)') jdy + read(fname(8+ioff:9+ioff),fmt='(I2.2)') hr + read(fname(10+ioff:11+ioff),fmt='(I2.2)') mn + read(fname(12+ioff:13+ioff),fmt='(I2.2)') sc + obs_time = obs_time + real(sc,8)/60.D0 / 2.D0 + + call jday2cal(jdy, yr, mt, dy) + call da_get_julian_time(yr,mt,dy,hr,mn,timbdy(2)) + + obs_time = obs_time + (timbdy(1) + timbdy(2)) / 2.D0 + +!! The time it takes to read time_bounds from each file is not insignificant. Above method is much faster. +! !! Determine central date of this file for obs binning +!!! ierr=nf_open(trim(this_view % fpath)//trim(fname),nf_nowrite,ncid) +!!! ierr=nf_inq_varid(ncid,'time_bounds',varid) +!!! ierr=nf_get_var_double(ncid,varid,timbdy) +!!! ierr=nf_close(ncid) +!!! j2000=(timbdy(1) + timbdy(2)) / 2.D0 /86400.D0 + + call da_get_cal_time(obs_time,yr,mt,dy,hr,mn,sc) + obs_time = obs_time * 60.D0 + + this_view % filedate(ifile) % yr = yr + this_view % filedate(ifile) % mt = mt + this_view % filedate(ifile) % dy = dy + this_view % filedate(ifile) % hr = hr + this_view % filedate(ifile) % mn = mn + this_view % filedate(ifile) % sc = sc + this_view % filedate(ifile) % obs_time = obs_time + + +!JJG: Note that this test being limited by time_slots prevents the use of data before/after the first/last time of the window even if the observations outside the window were recorded at times nearer to those bounds than data contained within the window. + if ( obs_time < time_slots(0) * 60.D0 .or. & + obs_time >= time_slots(num_fgat_time) * 60.D0 ) then + cycle + end if + + do ifgat=1,num_fgat_time + this_view % file_fgat_match(ifile,ifgat) = & + ( obs_time >= time_slots(ifgat-1) * 60.D0 .and. & + obs_time < time_slots(ifgat) * 60.D0 ) + if (this_view % file_fgat_match(ifile,ifgat)) exit + end do + + this_view % fgat_time_abs_diff(ifile,ifgat) = & + abs( obs_time - fgat_times_r(ifgat) ) + + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .ge. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. + else + this_view % min_time_diff(ichan, ifgat) = this_view % fgat_time_abs_diff(ifile, ifgat) + end if + + if (count(this_view % file_fgat_match(ifile,:)) .gt. 1) then + print*, 'WARNING: More than one bin was selected for ',trim(fname) + print*, 'num_bin_per_file = ',count(this_view % file_fgat_match(ifile,:)) + print*, 'obs_time = ',obs_time + print*, 'Ignoring this file for reading.' + this_view % file_fgat_match(ifile,:) = .false. + cycle + end if + end do + + do ifgat = 1, num_fgat_time + ! Select a single file for this view, channel, and fgat using min_time_diff + if ( count(this_view % file_fgat_match(:, ifgat)).gt.1 ) then + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle + call get_ichan(this_view % filechan(ifile), channel_list, nchan, ichan) + if ( this_view % fgat_time_abs_diff(ifile, ifgat) .gt. & + this_view % min_time_diff(ichan, ifgat) ) then + this_view % file_fgat_match(ifile,ifgat) = .false. + end if + end do + end if + end do + end do PrepViews + + !! If Full Disk is selected, take 2 passes over the data: + !! + 1st pass: (A) Determine portions of each view corresponding to this patch + !! for each fgat and each channel across observed domain + !! (B) Eliminate portions of broader views (Full Disk and CONUS) that + !! can be replaced by narrower views (CONUS and MESO) with times + !! closer to fgat time + !! + 2nd pass: read radiance values, convert to BT, calculate quantities for online cloud detection QC + !! + !! Otherwise only take one pass, and duplicated data cannot be removed from CONUS/MESO1/MESO2 + + npass = 1 + if (count(view_att(:) % select).gt.1 .and. view_att(1) % select) npass = 2 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Process data for views w/ nfiles > 1 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do ipass = 1, npass + write(unit=stdout,fmt=*) ' ' + write(unit=stdout,fmt=*) ' ' + write(unit=stdout,fmt='(A,I0,A,I2.2,A)') & + 'Starting pass ',ipass,& + ' of GOES-',satellite_id,' ABI data processing' + + !! Loop over the available views for this instrument (ABI) + do iview = 1, nviews + this_view => view_att(iview) + + if ( .not.this_view % select ) cycle + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Access netcdf channel/band files across all fgat windows + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + this_view % nfiles_used = 0 + + fgat_loop: do ifgat = 1, num_fgat_time + if (count(this_view % file_fgat_match(:, ifgat)) .lt. 1) then + cycle fgat_loop + end if + + first_file = 0 + do ifile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(ifile,ifgat) ) cycle + first_file = ifile + exit + end do + if (first_file .eq. 0) cycle fgat_loop + + if ( sum(this_view % nfiles_used(:)).eq.0) & + write(unit=stdout,fmt='(2A)') & + 'Processing data for view: ', trim(this_view % name) + write(unit=stdout,fmt='(2A)') & + ' fgat time: ',fgat_times_c(ifgat) + + yr = this_view % filedate(first_file) % yr + mt = this_view % filedate(first_file) % mt + dy = this_view % filedate(first_file) % dy + hr = this_view % filedate(first_file) % hr + mn = this_view % filedate(first_file) % mn + sc = this_view % filedate(first_file) % sc + write(unit=stdout, & + fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + ' data time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + + fname = trim(this_view % filename(first_file)) + + if ( .not.this_view % meta_initialized ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Get ABI metadata (first pass for FD, CONUS, MESO) + ! Only ny_global and nx_global need to be read for all views, but this is a cheap subroutine + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + write(unit=stdout,fmt='(A)') & + ' Reading abi metadata...' + + this_view % meta_initialized = .true. + + call get_abil1b_metadata( & + fname, this_view % ny_global, this_view % nx_global, & + req, rpol, pph, nam)! , lat_sat, lon_sat ) + +#ifdef DM_PARALLEL + ! Split the global ABI grid for this view into local segments + allocate ( this_view % ny_grid ( num_procs ) ) + allocate ( this_view % nx_grid ( num_procs ) ) + allocate ( this_view % ys_grid ( num_procs ) ) + allocate ( this_view % xs_grid ( num_procs ) ) + + call split_grid( this_view % ny_global, this_view % nx_global , & + this_view % ny_grid, this_view % nx_grid , & + this_view % ys_grid, this_view % xs_grid ) +#else + ! When mpi parallelism is not available, assign global values to local variables + this_view % ny_grid = this_view % ny_global + this_view % nx_grid = this_view % nx_global + this_view % ys_grid = 1 + this_view % xs_grid = 1 +#endif + end if + + ! Recall global dims for this_view + ny_global = this_view % ny_global + nx_global = this_view % nx_global + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Generate grid locations if + !! + CONUS or FD and first matching fgat + !! + MESO and any fgat (extent changes in time) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DoGridGen: if ( this_view % moving .or. .not.this_view % grid_initialized ) then + + ! Read grid from file, convert to lat, lon, satzen, satazi + write(unit=stdout,fmt='(2A)') & + ' Establishing abi grid info...' + + this_view % grid_initialized = .true. + + !======================================================== + ! Establish GOES metadata for this view and ifgat + ! (constant acros fgat's, except for this_view % moving) + !======================================================== + allocate( yy_abi (ny_global) ) + allocate( xx_abi (nx_global) ) + call get_abil1b_grid1( fname, & + ny_global, nx_global, & + yy_abi, xx_abi, & + this_view % yoff_fd, this_view % xoff_fd ) + + if ( iview.eq.1 ) then + yoff_fd = this_view % yoff_fd + xoff_fd = this_view % xoff_fd + this_view % yoff_fd = 1 + this_view % xoff_fd = 1 + else + this_view % yoff_fd = this_view % yoff_fd - yoff_fd + 1 + this_view % xoff_fd = this_view % xoff_fd - xoff_fd + 1 + end if + + !=========================================================== + ! Create a local array subset of observation location + ! quantities across processors. + !=========================================================== + nrad_local = ny_global * nx_global / (num_procs-1) + allocate( yy_1d (nrad_local) ) + allocate( xx_1d (nrad_local) ) + allocate( iy_1d (nrad_local) ) + allocate( ix_1d (nrad_local) ) + + n = 0 ; icount = 0 + +!JJG: Not convinced that these subgrids are needed. Might be able to loop over global X/Y instead. This solution may be overly complex. mod test for load balancing is still needed! + ! This loop over subgrids and the selective logic + ! below for myproc balances the processor loads + ! when some imager pixels are off-earth or outside + ! zenith-angle limits (Full Disk and CONUS) + do subgrid = 1, num_procs + ! Recall local dims for this_view + ny_local = this_view % ny_grid(subgrid) + nx_local = this_view % nx_grid(subgrid) + this_view % ys_local = this_view % ys_grid(subgrid) + this_view % xs_local = this_view % xs_grid(subgrid) + + do ixl = 1, nx_local + do iyl = 1, ny_local + iy = iyl + this_view % ys_local - 1 + ix = ixl + this_view % xs_local - 1 + if ( mod( iy-abi_superob_halfwidth-1, superob_width ) == 0 .and. & + mod( ix-abi_superob_halfwidth-1, superob_width ) == 0 ) then + !This mod test produces balanced loads between processors + if ( mod( n, num_procs ) .eq. myproc ) then + icount = icount + 1 + + yy_1d ( icount ) = yy_abi( iy ) + xx_1d ( icount ) = xx_abi( ix ) + iy_1d ( icount ) = iy + ix_1d ( icount ) = ix + end if + n = n + 1 + end if + end do + end do + end do + +! !This may work as a simplified replacement for the code above, not sure if loads will be balanced +! do ix = 1, nx_global +! do iy = 1, ny_global +! !This mod test produces balanced loads between processors +! if ( mod( n, num_procs ) .eq. myproc ) then +! icount = icount + 1 +! yy_1d ( icount ) = yy_abi( iy ) +! xx_1d ( icount ) = xx_abi( ix ) +! iy_1d ( icount ) = iy +! ix_1d ( icount ) = ix +! end if +! n = n + 1 +! end do +! end do + + nrad_local = icount + + deallocate( yy_abi, xx_abi ) + + allocate( earthmask_1d (1:nrad_local) ) + allocate( zenmask_1d (1:nrad_local) ) + allocate( this_view % lat_1d % local (1:nrad_local) ) + allocate( this_view % lon_1d % local (1:nrad_local) ) + allocate( this_view % satzen_1d % local (1:nrad_local) ) + allocate( this_view % satazi_1d % local (1:nrad_local) ) + allocate( this_view % iy_1d % local (1:nrad_local) ) + allocate( this_view % ix_1d % local (1:nrad_local) ) + + ! Assign values for iy, ix, lat, lon, satzen, satazi + this_view % iy_1d % local = iy_1d (1:nrad_local) + this_view % ix_1d % local = ix_1d (1:nrad_local) + deallocate( iy_1d ) + deallocate( ix_1d ) + + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations processed on this core: ', nrad_local + + if (nrad_local .gt. 0) & + call get_abil1b_grid2_1d( yy_1d(1:nrad_local), xx_1d(1:nrad_local), & + req, rpol, pph, nam, satellite_id, & + this_view % lat_1d % local, & + this_view % lon_1d % local, & + this_view % satzen_1d % local, & + this_view % satazi_1d % local, & + earthmask_1d, zenmask_1d ) + + ! Reduce values for iy, ix, lat, lon, satzen, satazi + ! using earth and zenith masks + nrad_mask = count ( earthmask_1d .and. zenmask_1d ) + this_view % lat_1d % local(1:nrad_mask) = & + pack(this_view % lat_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % lon_1d % local(1:nrad_mask) = & + pack(this_view % lon_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satzen_1d % local(1:nrad_mask) = & + pack(this_view % satzen_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % satazi_1d % local(1:nrad_mask) = & + pack(this_view % satazi_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % iy_1d % local(1:nrad_mask) = & + pack(this_view % iy_1d % local , earthmask_1d .and. zenmask_1d ) + this_view % ix_1d % local(1:nrad_mask) = & + pack(this_view % ix_1d % local , earthmask_1d .and. zenmask_1d ) + + nrad_local = nrad_mask + + deallocate( earthmask_1d ) + deallocate( zenmask_1d ) + deallocate( yy_1d, xx_1d ) + + ! Populate loc x, y and determine in/outside domain + allocate ( this_view % loc_1d % local (nrad_local) ) + allocate ( domainmask_1d (nrad_local) ) + allocate ( dummybool_2d (nrad_local,2) ) + allocate ( info_1d (nrad_local) ) + info_1d (:) % lat = this_view % lat_1d % local ( 1:nrad_local ) + info_1d (:) % lon = this_view % lon_1d % local ( 1:nrad_local ) + call da_llxy_1d ( info_1d, this_view % loc_1d % local(:), & + dummybool_2d(:,1), dummybool_2d(:,2) ) + domainmask_1d = .not.dummybool_2d(:,2) + deallocate( dummybool_2d ) + deallocate( info_1d ) + nrad_mask = count( domainmask_1d ) + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + ! COMMUNICATE 1D FIELDS FROM REMOTE PROCS TO LOCAL BUFFER + ! Note: these comms are a minor bottleneck, which will be + ! more noticeable for 4D-Var when MESO1/2 is processed + ! at multiple fgat's + ! Potential Solutions + ! SOLUTION 1: mpi_allgatherv (let's mpi figure out the most efficient way to distribute the data to all processes) + ! SOLUTION 2: round-robin mpi_bcast (may be less resource intensive with smaller communication chunks) + +! ! BEGIN SOLUTION 1 +!! !PACK UP DOMAIN DATA FROM THIS PROCESSOR +!! this_view % lat_1d % local (1:nrad_mask) = & +!! pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % lon_1d % local (1:nrad_mask) = & +!! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % satzen_1d % local (1:nrad_mask) = & +!! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % satazi_1d % local (1:nrad_mask) = & +!! pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % iy_1d % local (1:nrad_mask) = & +!! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % ix_1d % local (1:nrad_mask) = & +!! pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) +!! this_view % loc_1d % local (1:nrad_mask) % y = & +!! pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) +!! this_view % loc_1d % local (1:nrad_mask) % x = & +!! pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +! +! !ALLOCATE COMMUNICATION BUFFERS +! allocate ( nbufs ( num_procs ) ) +! allocate ( displs ( num_procs ) ) +!#ifdef DM_PARALLEL +! call mpi_allgather ( nrad_mask, 1, mpi_integer, nbufs, 1, mpi_integer, comm, ierr ) +!#else +! nbufs = nrad_mask +!#endif +! +! displs = 0 +! do iproc = 1, num_procs - 1 +! displs(iproc+1) = displs(iproc) + nbufs(iproc) +! end do +! +! this_view % nrad_on_domain = sum( nbufs ) +! +! allocate( buf_real( this_view % nrad_on_domain, 4 ) ) +! allocate( buf_int ( this_view % nrad_on_domain, 2 ) ) +! allocate( buf_loc ( this_view % nrad_on_domain ) ) +! +! buf_real = missing_r +! buf_int = missing +! buf_loc%y = missing_r +! buf_loc%x = missing_r +! +! !PACK UP DOMAIN DATA FROM THIS PROCESSOR +! buf_i = displs(iproc+1) + 1 +! buf_f = buf_i + nrad_mask - 1 +! buf_real( buf_i:buf_f, 1 ) = & +! pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 2 ) = & +! pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 3 ) = & +! pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) +! buf_real( buf_i:buf_f, 4 ) = & +! pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) +! buf_int ( buf_i:buf_f, 1 ) = & +! pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) +! buf_int ( buf_i:buf_f, 2 ) = & +! pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % y = & +! pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) +! buf_loc ( buf_i:buf_f ) % x = & +! pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) +! +!#ifdef DM_PARALLEL +! !PERFORM COMMS +! +! ! NOTE: MPI_IN_PLACE can only be used when comm is an intracommunicator +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,1), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,2), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_real(:,4), nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, mpi_integer, buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_loc(:)%y, nbufs, displs, true_mpi_real, comm, ierr ) +! call mpi_allgatherv ( & +! MPI_IN_PLACE, 0, true_mpi_real, buf_loc(:)%x, nbufs, displs, true_mpi_real, comm, ierr ) +! +!! call mpi_allgatherv ( & +!! this_view % lat_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,1), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % lon_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,2), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % satzen_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,3), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % satazi_1d % local (1:nrad_mask), nrad_mask, true_mpi_real, & +!! buf_real(:,4), nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % iy_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & +!! buf_int(:,1), nbufs, displs, mpi_integer, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % ix_1d % local (1:nrad_mask), nrad_mask, mpi_integer, & +!! buf_int(:,2), nbufs, displs, mpi_integer, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % loc_1d % local (1:nrad_mask) % y, nrad_mask, true_mpi_real, & +!! buf_loc(:)%y, nbufs, displs, true_mpi_real, comm, ierr ) +!! call mpi_allgatherv ( & +!! this_view % loc_1d % local (1:nrad_mask) % x, nrad_mask, true_mpi_real, & +!! buf_loc(:)%x, nbufs, displs, true_mpi_real, comm, ierr ) +!!#else +!! buf_real( :, 1 ) = this_view % lat_1d % local (1:nrad_mask) +!! buf_real( :, 2 ) = this_view % lon_1d % local (1:nrad_mask) +!! buf_real( :, 3 ) = this_view % satzen_1d % local (1:nrad_mask) +!! buf_real( :, 4 ) = this_view % satazi_1d % local (1:nrad_mask) +!! buf_int ( :, 1 ) = this_view % iy_1d % local (1:nrad_mask) +!! buf_int ( :, 2 ) = this_view % ix_1d % local (1:nrad_mask) +!! buf_loc ( : ) % y = this_view % loc_1d % local (1:nrad_mask) % y +!! buf_loc ( : ) % x = this_view % loc_1d % local (1:nrad_mask) % x +!#endif +! deallocate ( nbufs, displs ) +! ! END SOLUTION 1 + + ! BEGIN SOLUTION 2 + !ALLOCATE COMMUNICATION BUFFERS +#ifdef DM_PARALLEL + call mpi_allreduce( nrad_mask, nbuf, 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nbuf = nrad_mask +#endif + allocate( buf_real( nbuf, 4 ) ) + allocate( buf_int ( nbuf, 2 ) ) + allocate( buf_loc ( nbuf ) ) + + this_view % nrad_on_domain = nbuf + + buf_f = 0 + ProcLoop: do iproc = 0, num_procs-1 + nbuf = nrad_mask +#ifdef DM_PARALLEL + call mpi_bcast(nbuf, 1, mpi_integer, iproc, comm, ierr ) +#endif + if (nbuf .eq. 0) cycle ProcLoop + buf_i = buf_f + 1 + buf_f = buf_i + nbuf - 1 + + if (iproc .eq. myproc) then + !PACK UP DATA FROM THIS PROCESSOR + buf_real( buf_i:buf_f, 1 ) = & + pack(this_view % lat_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 2 ) = & + pack(this_view % lon_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 3 ) = & + pack(this_view % satzen_1d % local (1:nrad_local), domainmask_1d ) + buf_real( buf_i:buf_f, 4 ) = & + pack(this_view % satazi_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 1 ) = & + pack(this_view % iy_1d % local (1:nrad_local), domainmask_1d ) + buf_int ( buf_i:buf_f, 2 ) = & + pack(this_view % ix_1d % local (1:nrad_local), domainmask_1d ) + + buf_loc ( buf_i:buf_f ) % y = & + pack(this_view % loc_1d % local (1:nrad_local) % y, domainmask_1d ) + buf_loc ( buf_i:buf_f ) % x = & + pack(this_view % loc_1d % local (1:nrad_local) % x, domainmask_1d ) + else + buf_real(buf_i:buf_f,:) = missing_r + buf_int(buf_i:buf_f,:) = missing +! buf_loc(buf_i:buf_f)%y = missing_r +! buf_loc(buf_i:buf_f)%x = missing_r + end if +#ifdef DM_PARALLEL + !PERFORM COMMS + call mpi_bcast(buf_real(buf_i:buf_f,:), nbuf * 4, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast(buf_int (buf_i:buf_f,:), nbuf * 2, mpi_integer, iproc, comm, ierr ) + + !Only x & y components of loc need to be communicated + call mpi_bcast( buf_loc(buf_i:buf_f)%y, nbuf, true_mpi_real, iproc, comm, ierr ) + call mpi_bcast( buf_loc(buf_i:buf_f)%x, nbuf, true_mpi_real, iproc, comm, ierr ) +#endif + end do ProcLoop + ! END SOLUTION 2 + + deallocate ( this_view % lat_1d % local ) + deallocate ( this_view % lon_1d % local ) + deallocate ( this_view % satzen_1d % local ) + deallocate ( this_view % satazi_1d % local ) + deallocate ( this_view % iy_1d % local ) + deallocate ( this_view % ix_1d % local ) + deallocate ( this_view % loc_1d % local ) + deallocate ( domainmask_1d ) + + ! ASSOCIATE REMOTE POINTERS WITH BUFFERS CONTAINING DOMAIN-WIDE OBS + this_view % lat_1d % domain => buf_real(:,1) + this_view % lon_1d % domain => buf_real(:,2) + this_view % satzen_1d % domain => buf_real(:,3) + this_view % satazi_1d % domain => buf_real(:,4) + this_view % iy_1d % domain => buf_int (:,1) + this_view % ix_1d % domain => buf_int (:,2) + this_view % loc_1d % domain => buf_loc (:) + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within domain: ', this_view % nrad_on_domain + + ! Populate remainder of loc and determine in/outside patch + allocate ( patchmask_1d (this_view % nrad_on_domain) ) + allocate ( dummybool_2d (this_view % nrad_on_domain,1) ) + call da_llxy_1d ( locs = buf_loc, outside = dummybool_2d(:,1), do_xy = .false. ) + patchmask_1d = .not.dummybool_2d(:,1) + deallocate( dummybool_2d ) + this_view % nrad_on_patch = count(patchmask_1d) + write(unit=stdout,fmt='(3A,I0)') & + ' ',trim(this_view % name),' locations within this subdomain: ', this_view % nrad_on_patch + + if ( this_view % nrad_on_patch .gt. 0 ) then + if ( allocated ( this_view % patchmask ) ) then + deallocate ( this_view % patchmask ) + deallocate ( this_view % lat_1d % patch ) + deallocate ( this_view % lon_1d % patch ) + deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % satazi_1d % patch ) + deallocate ( this_view % iy_1d % patch ) + deallocate ( this_view % ix_1d % patch ) + deallocate ( this_view % loc_1d % patch ) + end if + allocate( this_view % lat_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % lon_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satzen_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % satazi_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % iy_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % ix_1d % patch (this_view % nrad_on_patch) ) + allocate( this_view % loc_1d % patch (this_view % nrad_on_patch) ) + + this_view % lat_1d % patch = & + pack( this_view % lat_1d % domain, patchmask_1d ) + this_view % lon_1d % patch = & + pack( this_view % lon_1d % domain, patchmask_1d ) + this_view % satzen_1d % patch = & + pack( this_view % satzen_1d % domain, patchmask_1d ) + this_view % satazi_1d % patch = & + pack( this_view % satazi_1d % domain, patchmask_1d ) + this_view % iy_1d % patch = & + pack( this_view % iy_1d % domain, patchmask_1d ) + this_view % ix_1d % patch = & + pack( this_view % ix_1d % domain, patchmask_1d ) + this_view % loc_1d % patch = & + pack( this_view % loc_1d % domain, patchmask_1d ) + + ! Determine grid extents for this patch on this_view and on Full Disk + this_view % ys_p = minval(this_view % iy_1d % patch) + this_view % ye_p = maxval(this_view % iy_1d % patch) + this_view % xs_p = minval(this_view % ix_1d % patch) + this_view % xe_p = maxval(this_view % ix_1d % patch) + this_view % ys_p_fd = this_view % ys_p + this_view % yoff_fd - 1 + this_view % ye_p_fd = this_view % ye_p + this_view % yoff_fd - 1 + this_view % xs_p_fd = this_view % xs_p + this_view % xoff_fd - 1 + this_view % xe_p_fd = this_view % xe_p + this_view % xoff_fd - 1 + +! write(stdout,*) 'ABI grid extents for this view:' +! write(stdout,'(A,4I10)') 'ys_p, ye_p, xs_p, xe_p ',this_view % ys_p, this_view % ye_p, this_view % xs_p, this_view % xe_p +! write(stdout,*) 'ABI grid extents for Full Disk:' +! write(stdout,'(A,4I10)') 'ys_p_fd, ye_p_fd, xs_p_fd, xe_p_fd',this_view % ys_p_fd, this_view % ye_p_fd, this_view % xs_p_fd, this_view % xe_p_fd + + ! Setup ZZ clddet extents + this_view % ys_local = max(this_view % ys_p - abi_halo_width, 1) + this_view % ye_local = min(this_view % ye_p + abi_halo_width, ny_global) + this_view % xs_local = max(this_view % xs_p - abi_halo_width, 1) + this_view % xe_local = min(this_view % xe_p + abi_halo_width, nx_global) + + ! Setup patch mask for this view, including ZZ clddet buffer + allocate( this_view % patchmask( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + + this_view % patchmask = .false. + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + + cldqc = .true. + do jy = iy - abi_halo_width, iy + abi_halo_width + do jx = ix - abi_halo_width, ix + abi_halo_width + if ( & + jy.ge.1 .and. jy.le.ny_global & + .and. jx.ge.1 .and. jx.le.nx_global & + ) then + this_view % patchmask ( jy, jx, 2 ) = .true. + else + cldqc = .false. + end if + end do + end do + this_view % patchmask ( iy, ix, 1 ) = cldqc + end do + this_view % nrad_on_patch_cldqc = count( this_view % patchmask (:,:,1) ) + else + this_view % nrad_on_patch_cldqc = 0 + end if +! write(unit=stdout,fmt='(3A,I0)') & +! ' ',trim(this_view % name),' locations within this subdomain eligible for ZZ clddet: ', this_view % nrad_on_patch_cldqc + + + !FREE UP POINTERS AND BUFFERS + nullify ( this_view % lat_1d % domain ) + nullify ( this_view % lon_1d % domain ) + nullify ( this_view % satzen_1d % domain ) + nullify ( this_view % satazi_1d % domain ) + nullify ( this_view % iy_1d % domain ) + nullify ( this_view % ix_1d % domain ) + nullify ( this_view % loc_1d % domain ) + deallocate ( buf_real, buf_int, buf_loc ) + deallocate ( patchmask_1d ) + +#ifdef DM_PARALLEL + call mpi_allreduce( this_view % nrad_on_patch_cldqc, & + this_view % nrad_on_domain_cldqc, & + 1, mpi_integer, mpi_sum, comm, ierr ) + call mpi_barrier(comm, ierr) +#else + this_view % nrad_on_domain_cldqc = this_view % nrad_on_patch_cldqc +#endif + end if DoGridGen + + if ( iview.eq.1 .and. ipass.lt.npass .and. & + sum(this_view % nfiles_used(:)).eq.0 ) then + if ( this_view % nrad_on_patch_cldqc .gt. 0 ) then + allocate( view_mask( & + this_view % ys_p_fd-2:this_view % ye_p_fd+2, & + this_view % xs_p_fd-2:this_view % xe_p_fd+2, & + nviews, nchan, num_fgat_time ) ) + view_mask = .false. + end if + use_view_mask = .true. + end if + +! if ( (ipass.lt.npass .and. iview.eq.1) .or. .not.use_view_mask ) then +! num_goesabi_global = num_goesabi_global + this_view % nrad_on_domain_cldqc +! !ptotal(ifgat) = ptotal(ifgat) + this_view % nrad_on_domain_cldqc +! end if + + PatchMatch: if (this_view % nrad_on_patch_cldqc .gt. 0) then + + ! Loop over channels; each process reads radiance data only for its subdomain + ChannelLoop: do ichan = 1, nchan + ifile = 0 + do jfile = 1, this_view % nfiles + if ( .not. this_view % file_fgat_match(jfile,ifgat) ) cycle + call get_ichan(this_view % filechan(jfile), channel_list, nchan, jchan) + if ( ichan .eq. jchan ) then + ifile = jfile + exit + end if + end do + if ( ifile .eq. 0 ) cycle ChannelLoop + + this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) + 1 + + VIEW_SELECT: & + if ( ipass.lt.npass .and. use_view_mask ) then + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Determine which view has the closest observed + !! time to fgat for this channel + !! Note: this only needs to be done for a single channel, + !! unless individual channel files are missing at fgat. + !! Solution where file view availability differs by channel used here. + !! (only available when FD data present for one of the fgat times) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if ( iview.eq.1 ) then + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + view_mask( iyfd, ixfd, iview, ichan, ifgat) = & + this_view % patchmask ( iy, ix, 1 ) + end do + else + best_view = .true. +! do jview = 1, iview-1 !This assumes MESO1 and MESO2 are in identical locations + do jview = 1, min(iview-1,2) !This assumes MESO1 and MESO2 do not overlap + best_view = best_view .and. & + this_view % min_time_diff(ichan, ifgat) .lt. & + view_att(jview) % min_time_diff(ichan, ifgat) + end do + if ( best_view ) then + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + if ( this_view % patchmask ( iy, ix, 1 ) ) then + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + + view_mask( iyfd, ixfd, iview, ichan, ifgat) = .true. + + !This assumes MESO1 and MESO2 do not overlap + view_mask( iyfd, ixfd, 1:min(iview-1,2), ichan, ifgat) = .false. + +! !This assumes MESO1 and MESO2 are in identical locations +! view_mask( iyfd, ixfd, 1:iview-1, ichan, ifgat) = .false. + end if + end do + end if + end if + + else + !!Utilizing these masks to eliminate data: + !! + earthmask + !! + zenmask + !! + view_mask [only if npass > 1] + !! + model domain mask + !! + patch mask + !! + thinning + + allocate( allmask_p( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + allmask_p = this_view % patchmask ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) + + allocate( readmask_p( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + readmask_p = this_view % patchmask ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) + + ! Only use locations where this view is nearest to this fgat time + ! - only available when FD data present for any fgat time + if ( use_view_mask ) then + if ( .not.any( & + view_mask ( this_view % ys_p_fd:this_view % ye_p_fd, & + this_view % xs_p_fd:this_view % xe_p_fd, & + iview, ichan, ifgat ) & + ) ) then + deallocate(allmask_p, readmask_p) + write(unit=stdout,fmt='(3A,I0)') & + ' ZERO pixels selected for ',trim(this_view % name),' on band ', channel_list(ichan) + this_view % nfiles_used(ifgat) = this_view % nfiles_used(ifgat) - 1 + cycle ChannelLoop + end if + do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + iyfd = iy + this_view % yoff_fd-1 + ixfd = ix + this_view % xoff_fd-1 + + allmask_p( iy, ix ) = & + ( allmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) + + readmask_p( iy, ix ) = & + ( readmask_p( iy, ix ) .and. view_mask( iyfd, ixfd, iview, ichan, ifgat) ) + end do + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Read radiance and convert to brightness temp. + !! once per permutation of + !! + INST VIEW (FD, CONUS, MESOx2) + !! + fgat + !! + channel/band + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + write(unit=stdout,fmt='(A,I0,A,I0)') & + ' Reading ', count(readmask_p), ' abi radiances for band ',channel_list(ichan) + if ( use_clddet_zz) write(unit=stdout,fmt='(A,I0)') & + ' which includes the cloud detection halo' + TEMPIR_ifile = -1 + if ( use_clddet_zz .and. channel_list(ichan).eq.14 ) then + ! Require earlier file to be withn 1/2 of TEMPIR_delay_minutes + TEMPIR_min_time_diff = TEMPIR_delay_minutes +!write(unit=stdout,fmt='(A,F14.2)') & +! ' ref_time (min): ', this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes + do jfile = 1, this_view % nfiles + if ( this_view % filechan(jfile) .ne. channel_list(ichan) .or. & + jfile .eq. ifile ) cycle + + TEMPIR_time_abs_diff = & + abs( this_view % filedate(jfile) % obs_time / 60.D0 - & + (this_view % filedate(ifile) % obs_time / 60.D0 - TEMPIR_delay_minutes) ) + + if ( TEMPIR_time_abs_diff .lt. TEMPIR_min_time_diff ) then + TEMPIR_ifile = jfile + TEMPIR_min_time_diff = TEMPIR_time_abs_diff + end if + end do + if ( TEMPIR_min_time_diff .gt. 0.5 * TEMPIR_delay_minutes ) then +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: minimum time difference is too large - ',TEMPIR_min_time_diff,' minutes' + TEMPIR_ifile = -1 +! else +! write(unit=stdout,fmt='(A,F7.2,A)') & +! ' TEMPIR: minimum time difference is accetable - ',TEMPIR_min_time_diff,' minutes' + end if + end if + + ! Allocate and read bt for this patch and current time + if ( TEMPIR_ifile.gt.0 ) then + allocate( rad_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + + allocate( bt_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 2 ) ) + else + allocate( rad_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) ) + + allocate( bt_p ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local, 1 ) ) + end if + + fname = trim(this_view % filename(ifile)) + call get_abil1b_rad( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, inst, ichan, & + rad_p(:,:,1), bc1, bc2, fk1, fk2 ) + + bt_p = missing_r + where (readmask_p) + bt_p(:,:,1) = rad2bt(rad_p(:,:,1), bc1, bc2, fk1, fk2) + end where + + !JJG: It is possible for readmask_p to differ across channels. + ! readmask_p needs to be incorporated, but presently causes error between channel reading + ! when lining up channels to identical members of linked p list. + ! Fixing this will require moving away from linked list including the readmask_p quality + ! flag in the datalink_type. + ! Presently readmask_p is used internally within get_abil1b_rad to set rad_p=missing_r (works fine) + !allmask_p = (allmask_p .and. readmask_p) + if ( TEMPIR_ifile.gt.0 ) then + fname = trim(this_view % filename(TEMPIR_ifile)) + call get_abil1b_rad( fname, & + this_view % ys_local, this_view % ye_local, & + this_view % xs_local, this_view % xe_local, & + readmask_p, inst, ichan, & + rad_p(:,:,2), bc1, bc2, fk1, fk2 ) + + where (readmask_p) + bt_p(:,:,2) = rad2bt(rad_p(:,:,2), bc1, bc2, fk1, fk2) + end where + + yr = this_view % filedate(TEMPIR_ifile) % yr + mt = this_view % filedate(TEMPIR_ifile) % mt + dy = this_view % filedate(TEMPIR_ifile) % dy + hr = this_view % filedate(TEMPIR_ifile) % hr + mn = this_view % filedate(TEMPIR_ifile) % mn + sc = this_view % filedate(TEMPIR_ifile) % sc +! write(unit=stdout, & +! fmt='(A,I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & +! ' TEMPIR time: ',yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + end if + + first_chan = (this_view % nfiles_used(ifgat).eq.1) + + !! Write bt, lat, lon, satzen, satazi, solzen, solazi to datalink structures + if (first_chan) then + p_fgat => p + + yr = this_view % filedate(ifile) % yr + mt = this_view % filedate(ifile) % mt + dy = this_view % filedate(ifile) % dy + hr = this_view % filedate(ifile) % hr + mn = this_view % filedate(ifile) % mn + sc = this_view % filedate(ifile) % sc + + allocate( solzen_1d (this_view % nrad_on_patch) ) + allocate( solazi_1d (this_view % nrad_on_patch) ) + + call da_get_solar_angles_1d ( yr, mt, dy, hr, mn, sc, & + this_view % lat_1d % patch, this_view % lon_1d % patch, & + solzen_1d, solazi_1d ) + + if ( use_clddet_zz .and. & + abi_halo_width-abi_superob_halfwidth.ge.1) then + ! Allocate terrain_hgt using local indices for this view + allocate( terrain_hgt ( & + this_view % ys_local:this_view % ye_local, & + this_view % xs_local:this_view % xe_local ) ) + + ! Read terrain file using Full Disk global indices + write(*,*) 'DEBUG da_read_obs_ncgoesabi, ys_local, ye_local, yoff_fd-1: ', & + this_view % ys_local, this_view % ye_local, this_view % yoff_fd-1 + write(*,*) 'DEBUG da_read_obs_ncgoesabi, xs_local, xe_local, xoff_fd-1: ', & + this_view % xs_local, this_view % xe_local, this_view % xoff_fd-1 + + call get_abil1b_terr( terr_fname, & + this_view % ys_local + this_view % yoff_fd - 1, & + this_view % ye_local + this_view % yoff_fd - 1, & + this_view % xs_local + this_view % xoff_fd - 1, & + this_view % xe_local + this_view % xoff_fd - 1, & + terrain_hgt ) + + end if + + allocate(thinmask(this_view % ys_p:this_view % ye_p, & + this_view % xs_p:this_view % xe_p)) + thinmask = .false. + else + p => p_fgat + end if + + PixelLoop: do n = 1, this_view % nrad_on_patch + iy = this_view % iy_1d % patch (n) + ix = this_view % ix_1d % patch (n) + + if (.not. allmask_p( iy, ix )) cycle PixelLoop + + if (first_chan) then + info % lat = this_view % lat_1d % patch (n) ! latitude + info % lon = this_view % lon_1d % patch (n) ! longitude + num_goesabi_local = num_goesabi_local + 1 + end if + + if (thinning) then + if (first_chan) then + dlat_earth = info % lat + dlon_earth = info % lon + if (dlon_earth=r360) dlon_earth = dlon_earth-r360 + dlat_earth = dlat_earth * deg2rad + dlon_earth = dlon_earth * deg2rad + crit = 1. + call map2grids(inst,ifgat,dlat_earth,dlon_earth,crit,iobs,itx,1,itt,iout,iuse) + if (.not. iuse) then + num_goesabi_thinned=num_goesabi_thinned+1 + thinmask( iy, ix ) = .true. + cycle PixelLoop + end if + else + if (thinmask( iy, ix )) cycle PixelLoop + end if + end if + + if (first_chan) then + num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) + 1 + + allocate ( p % tb_inv (1:nchan) ) + allocate ( p % rad_obs (1:nchan) ) + p % tb_inv = missing_r + p % rad_obs = missing_r + + write(unit=info % date_char, & + fmt='(I4.4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)') & + yr, '-', mt, '-', dy, '_', hr, ':', mn, ':', sc + if ( allocated(terrain_hgt) ) then + info % elv = terrain_hgt( iy, ix ) + else + info % elv = 0.0 + end if + p % info = info + p % loc = this_view % loc_1d % patch (n) + + p % landsea_mask = 1 ! ??? + if (use_view_mask) then + p % scanpos = & + ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / view_att(1) % ny_global + ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) + else + p % scanpos = & + ( iy + this_view % yoff_fd-1 - 1) * (nscan+1) / 5424 + ! ??? "scan" position (IS THIS CORRECT? NECESSARY? iFOV?) + end if + p % satzen = this_view % satzen_1d % patch (n) + p % satazi = this_view % satazi_1d % patch (n) + p % solzen = solzen_1d (n) + p % solazi = solazi_1d (n) + if ( p % solzen < 0. ) p % solzen = 150. + p % sensor_index = inst + p % ifgat = ifgat + end if + + ! Super-ob the radiance, then convert to BT for this channel + tbuf = abi_superob_halfwidth + if (abi_halo_width.ge.tbuf .and. tbuf.gt.0) then + ! require that nkeep >= superob_width to filter out bad data + nkeep = count ( rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. 0.0 ) + if (nkeep .ge. superob_width) then + p % rad_obs(ichan) = sum( pack( & + rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ), & + rad_p ( iy-tbuf:iy+tbuf, ix-tbuf:ix+tbuf, 1 ) .gt. 0.0 ) ) & + / real(nkeep,r_double) + end if + else + ! Extract single pixel BT and radiance value for this channel + p % rad_obs(ichan) = rad_p( iy, ix, 1 ) + end if + if (p % rad_obs(ichan) .gt. 0.0) then + p % tb_inv(ichan) = rad2bt(p % rad_obs(ichan), bc1, bc2, fk1, fk2 ) + end if + + ! Preprocessing for Cloud Mask (da_qc_goesabi.inc) including + ! extracting Tb values from cloud QC buffer + if (.not. allocated(p % superob)) then + allocate( p % superob(superob_width,superob_width) ) + end if + + ! Loops over superob pixels + do jsup = 1, superob_width + do isup = 1, superob_width + iysup = iy + jsup-1-abi_superob_halfwidth + ixsup = ix + isup-1-abi_superob_halfwidth + if (first_chan) then + allocate ( p % superob(isup,jsup) % tb_obs (1:nchan,1) ) + allocate ( p % superob(isup,jsup) % cld_qc(1) ) + allocate ( p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(nchan) ) + end if + p % superob(isup,jsup) % tb_obs(ichan,1) = bt_p( iysup, ixsup, 1 ) + + tbuf = 1 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + nkeep = count ( bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) .gt. 0.0 ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ), & + bt_p ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) .gt. 0.0) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = sigma + else + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = missing_r + end if + if (channel_list(ichan).eq.14) then + + if ( allocated(terrain_hgt) ) then + ! Determine sigma_z of terrain height across these pixels + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = terrain_hgt( iysup, ixsup ) + nkeep = count ( terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ) .gt. missing_r ) + if (nkeep .gt. 0) then + allocate( tb_temp ( nkeep, 1 ) ) + tb_temp(:,1) = pack( terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ), & + terrain_hgt ( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf ) .gt. missing_r) + mu = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma = sqrt( sum( (tb_temp(:,1) - mu)**2 ) / real(nkeep,r_double) ) + deallocate( tb_temp ) + + ! Values for RTCT cloud QC + ! - channel 14 and sigma_z (std. dev. of terrain height in km) + ! w/ landmask and lapse rate of 7 K km^-1 + + temp_max = 0. + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( bt_p( jy, jx, 1) .gt. 0. ) & + temp_max = max(temp_max,bt_p( jy, jx, 1 ) ) + end do + end do + + if (temp_max .gt. missing_r) then + ! Store RTCT + p % superob(isup,jsup) % cld_qc(1) % RTCT = temp_max - bt_p( iysup, ixsup, 1 ) - & + 3.0_r_double * 0.007_r_double * sigma + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + end if + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + end if + else + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = missing_r + end if + + end if + else + p % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3(ichan) = missing_r + if (channel_list(ichan).eq.14) then + p % superob(isup,jsup) % cld_qc(1) % RTCT = missing_r + p % superob(isup,jsup) % cld_qc(1) % terr_hgt = missing_r + end if + end if + + ! Values for RFMFT cloud QC + ! - channels 14 and 15 + tbuf = 10 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + if (channel_list(ichan).eq.14) then + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij = -1 + + !Determine Neighboring Warm Center (NWC) for this pixel + temp_max = 0.0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( bt_p( jy, jx, 1 ) .gt. temp_max ) then + temp_max = bt_p( jy, jx, 1 ) + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(1) = jy + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(2) = jx + end if + end do + end do + p % superob(isup,jsup) % cld_qc(1) % RFMFT = & + bt_p( iysup, ixsup, 1 ) - temp_max + end if + if (channel_list(ichan).eq.15 .and. & + all(p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij.gt.0)) then + + temp_max = bt_p ( p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(1), & + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij(2), 1 ) + + p % superob(isup,jsup) % cld_qc(1) % RFMFT = abs( & + p % superob(isup,jsup) % cld_qc(1) % RFMFT + & + temp_max - bt_p( iysup, ixsup, 1 ) ) + + end if + else + if ( any( channel_list(ichan).eq.(/14,15/) ) ) then + + p % superob(isup,jsup) % cld_qc(1) % RFMFT = missing_r + + p % superob(isup,jsup) % cld_qc(1) % RFMFT_ij = -1 + + end if + end if + + ! Values for CIRH2O cloud QC + ! - channels 10 and 14 for Pearson correlation coefficient of CIRH2O test + tbuf = 2 + if (abi_halo_width-abi_superob_halfwidth.ge.tbuf .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0) then + + if (channel_list(ichan).eq.10) then + + allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ( & + iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 2 ) ) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi(:,:,1) = & + bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) + + end if + if (channel_list(ichan).eq.14 .and. & + size(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi).gt.1) then + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi(:,:,2) = & + bt_p( iysup-tbuf:iysup+tbuf, ixsup-tbuf:ixsup+tbuf, 1 ) + nkeep = 0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, : ) .gt. missing_r) ) nkeep = nkeep + 1 + end do + end do + allocate( tb_temp ( nkeep, 2 ) ) + ikeep = 0 + do jy = iysup-tbuf, iysup+tbuf + do jx = ixsup-tbuf, ixsup+tbuf + if ( all(p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, : ) .gt. missing_r) ) then + ikeep = ikeep + 1 + tb_temp(ikeep,1) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, 1 ) + tb_temp(ikeep,2) = & + p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi( jy, jx, 2 ) + end if + end do + end do + + mu10 = sum( tb_temp(:,1) ) / real(nkeep,r_double) + sigma10 = sqrt( sum( (tb_temp(:,1) - mu10)**2 ) & + / real(nkeep,r_double) ) + + mu14 = sum( tb_temp(:,2) ) / real(nkeep,r_double) + sigma14 = sqrt( sum( (tb_temp(:,2) - mu14)**2 ) / & + real(nkeep,r_double) ) + + pearson = sum((tb_temp(:,1) - mu10) * (tb_temp(:,2) - mu14)) / & + real(nkeep,r_double) / ( sigma10 * sigma14 ) + + deallocate( tb_temp ) + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + !allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1) ) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = pearson + + end if + else + if ( any( channel_list(ichan).eq.(/10,14/) ) ) then + + if ( allocated( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi) + + !allocate( p % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi (1,1,1)) + + p % superob(isup,jsup) % cld_qc(1) % CIRH2O = missing_r + + end if + end if + + ! Values for TEMPIR cloud QC + ! - channel 14 + if ( use_clddet_zz .and. (channel_list(ichan).eq.14) ) then + + p % superob(isup,jsup) % cld_qc(1) % TEMPIR = missing_r + + if ( TEMPIR_ifile.gt.0 .and. & + bt_p( iysup, ixsup, 1 ).gt.0.0 .and. & + bt_p( iysup, ixsup, 2 ).gt.0.0 ) then + if ( bt_p( iysup, ixsup, 2 ).lt.330. ) & + p % superob(isup,jsup) % cld_qc(1) % TEMPIR = & + bt_p( iysup, ixsup, 2 ) - bt_p( iysup, ixsup, 1 ) + end if + + end if + end do ! isup + end do ! jsup + + if (first_chan) & + allocate (p % next) ! add next data + + p => p % next + + if (first_chan) & + nullify (p % next) + + end do PixelLoop + if ( allocated(bt_p) ) deallocate ( bt_p ) + if ( allocated(rad_p) ) deallocate ( rad_p ) + if ( allocated(solzen_1d) ) deallocate ( solzen_1d ) + if ( allocated(solazi_1d) ) deallocate ( solazi_1d ) + if ( allocated(allmask_p) ) deallocate ( allmask_p ) + if ( allocated(readmask_p) ) deallocate ( readmask_p ) + end if VIEW_SELECT + end do ChannelLoop + if ( allocated(terrain_hgt) ) deallocate ( terrain_hgt ) + if ( allocated(thinmask) ) deallocate ( thinmask ) + else + write(unit=stdout,fmt='(A)') & + ' No pixels to read within this subdomain. Waiting for other processors...' + end if PatchMatch + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + + end do fgat_loop ! end fgat loop + + if ( (this_view % moving .or. ipass.eq.npass) .and. this_view%nrad_on_patch.gt.0 ) then + ! Deallocate location info + deallocate ( this_view % patchmask ) + deallocate ( this_view % lat_1d % patch ) + deallocate ( this_view % lon_1d % patch ) + deallocate ( this_view % satzen_1d % patch ) + deallocate ( this_view % satazi_1d % patch ) + deallocate ( this_view % iy_1d % patch ) + deallocate ( this_view % ix_1d % patch ) + deallocate ( this_view % loc_1d % patch ) + end if + + if (ipass .eq. 2) tot_files_used = tot_files_used + sum(view_att(iview) % nfiles_used) + + end do ! end view loop + + end do ! end pass loop + + if ( allocated(view_mask) ) deallocate(view_mask) + + do iview = 1, nviews + if ( .not.view_att(iview) % select ) cycle + this_view => view_att(iview) + deallocate ( this_view % filename ) + deallocate ( this_view % filechan ) + deallocate ( this_view % filedate ) + deallocate ( this_view % file_fgat_match ) + deallocate ( this_view % fgat_time_abs_diff ) + deallocate ( this_view % min_time_diff ) + deallocate ( this_view % nfiles_used ) + if ( allocated( this_view % ny_grid ) ) deallocate ( this_view % ny_grid ) + if ( allocated( this_view % nx_grid ) ) deallocate ( this_view % nx_grid ) + if ( allocated( this_view % ys_grid ) ) deallocate ( this_view % ys_grid ) + if ( allocated( this_view % xs_grid ) ) deallocate ( this_view % xs_grid ) + end do + deallocate(view_att) + + if (tot_files_used .lt. 1) then + write(unit=message(1),fmt=*) "Either no L1B data found or no matching fgat windows for GOES-",satellite_id," ABI using prefix ",INST_PREFIX, " for this process rank. This subdomain may have an unacceptable zenith angle or fall entirely outside the GOES viewing extent." + +! write(unit=message(1),fmt='(A)') "Either no L1B data found or no matching" +! write(unit=message(2),fmt='(A,I2,A)') "fgat windows for GOES-",satellite_id," ABI using" +! write(unit=message(3),fmt='(3A)') "prefix ",INST_PREFIX, " for this process rank." +! write(unit=message(4),fmt='(A)') "This subdomain may have an unacceptable zenith " +! write(unit=message(5),fmt='(A)') "angle or fall entirely outside the GOES viewing" +! write(unit=message(6),fmt='(A)') "extent." + + call da_warning(__FILE__,__LINE__, message(1:1)) + end if + +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_local, & + num_goesabi_global, & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + num_goesabi_global = num_goesabi_local +#endif + +!------------------------------------------------------ + ! NOTE: Remainder of this subroutine modified from da_read_obs_ncgoesimg.inc + + if (thinning .and. num_goesabi_global > 0 ) then +#ifdef DM_PARALLEL + + ! Get minimum crit and associated processor index. + j = 0 + do ifgat = 1, num_fgat_time + j = j + thinning_grid(inst,ifgat) % itxmax + end do + + + allocate ( in (j) ) + allocate ( out (j) ) + j = 0 + do ifgat = 1, num_fgat_time + do i = 1, thinning_grid(inst,ifgat) % itxmax + j = j + 1 + in(j) = thinning_grid(inst,ifgat) % score_crit(i) + end do + end do + + call mpi_reduce(in, out, j, true_mpi_real, mpi_min, root, comm, ierr) + + call wrf_dm_bcast_real (out, j) + + j = 0 + do ifgat = 1, num_fgat_time + do i = 1, thinning_grid(inst,ifgat) % itxmax + j = j + 1 + if ( ABS(out(j)-thinning_grid(inst,ifgat) % score_crit(i)) > 1.0D-10 ) thinning_grid(inst,ifgat) % ibest_obs(i) = 0 + end do + end do + deallocate( in ) + deallocate( out ) + +#endif + ! Delete the nodes being thinned out + p => head + prev => head + head_found = .false. + num_goesabi_used_tmp = sum(num_goesabi_used_fgat) + + do j = 1, num_goesabi_used_tmp + n = p % sensor_index + ifgat = p % ifgat + found = .false. + + do i = 1, thinning_grid(n,ifgat) % itxmax + if ( thinning_grid(n,ifgat) % ibest_obs(i) == j .and. thinning_grid(n,ifgat) % score_crit(i) < 9.99e6_r_double ) then + found = .true. + exit + end if + end do + + ! free current data + if ( .not. found ) then + current => p + p => p % next + if ( head_found ) then + prev % next => p + else + head => p + prev => p + end if + deallocate ( current % tb_inv ) + deallocate ( current % rad_obs ) + if ( allocated( current % superob ) ) then + do jsup = 1, superob_width + do isup = 1, superob_width + deallocate ( current % superob(isup,jsup) % tb_obs ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) + deallocate ( current % superob(isup,jsup) % cld_qc ) + end do + end do + deallocate ( current % superob ) + end if + deallocate ( current ) + num_goesabi_thinned = num_goesabi_thinned + 1 + num_goesabi_used_fgat(ifgat) = num_goesabi_used_fgat(ifgat) - 1 + continue + end if + + if ( found .and. head_found ) then + prev => p + p => p % next + continue + end if + if ( found .and. .not. head_found ) then + head_found = .true. + head => p + prev => p + p => p % next + end if + + end do + + end if ! End of thinning +!stop + num_goesabi_used = sum(num_goesabi_used_fgat) + iv % total_rad_pixel = iv % total_rad_pixel + num_goesabi_used + iv % total_rad_channel = iv % total_rad_channel + num_goesabi_used*nchan + + iv % info(radiance) % nlocal = iv % info(radiance) % nlocal + num_goesabi_used + iv % info(radiance) % ntotal = iv % info(radiance) % ntotal + num_goesabi_global + + do i = 1, num_fgat_time +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_used_fgat(i), & + ptotal(i), & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + ptotal(i) = num_goesabi_used_fgat(i) +#endif + end do + + do i = 1, num_fgat_time + ptotal(i) = ptotal(i) + ptotal(i-1) + iv % info(radiance) % ptotal(i) = iv % info(radiance) % ptotal(i) + ptotal(i) + end do + +#ifdef DM_PARALLEL + call mpi_allreduce( num_goesabi_thinned, & + nthinned, & + 1, mpi_integer, mpi_sum, comm, ierr ) +#else + nthinned = num_goesabi_thinned +#endif + + if ( iv % info(radiance) % ptotal(num_fgat_time) /= (iv % info(radiance) % ntotal - nthinned) ) then + write(unit=message(1),fmt='(A,I10,A,I10)') & + "Number of ntotal - nthinned:",iv % info(radiance) % ntotal - nthinned," is different from the sum of ptotal:", iv % info(radiance) % ptotal(num_fgat_time) + call da_warning(__FILE__,__LINE__,message(1:1)) + endif + + write(unit=stdout,fmt='(a)') 'num_goesabi_global, num_goesabi_thinned_global, num_goesabi_used_global' + write(unit=stdout,fmt=*) num_goesabi_global, nthinned, ptotal(num_fgat_time) + + write(unit=stdout,fmt='(a)') 'num_goesabi_local, num_goesabi_thinned, num_goesabi_used' + write(unit=stdout,fmt=*) num_goesabi_local, num_goesabi_thinned, num_goesabi_used + + ! 5.0 allocate innovation radiance structure + !---------------------------------------------------------------- + + + if (num_goesabi_used > 0) then + iv % instid(inst) % num_rad = num_goesabi_used + iv % instid(inst) % info % nlocal = num_goesabi_used + write(unit=stdout,FMT='(a,i3,2x,a,3x,i10)') & + 'Allocating space for radiance innov structure', & + inst, iv % instid(inst) % rttovid_string, iv % instid(inst) % num_rad + call da_allocate_rad_iv (inst, nchan, iv) + end if + + ! 6.0 assign sequential structure to innovation structure + !------------------------------------------------------------- + p => head + do n = 1, num_goesabi_used + i = p % sensor_index + call da_initialize_rad_iv (i, n, iv, p) + current => p + p => p % next + + ! free current data + deallocate ( current % tb_inv ) + deallocate ( current % rad_obs ) + if ( allocated ( current % superob ) ) then + do jsup = 1, superob_width + do isup = 1, superob_width + deallocate ( current % superob(isup,jsup) % tb_obs ) + if ( allocated ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) ) & + deallocate ( current % superob(isup,jsup) % cld_qc(1) % CIRH2O_abi ) + deallocate ( current % superob(isup,jsup) % cld_qc(1) % tb_stddev_3x3 ) + deallocate ( current % superob(isup,jsup) % cld_qc ) + end do + end do + deallocate ( current % superob ) + end if + deallocate ( current ) + end do + deallocate ( p ) + deallocate (ptotal) + +#ifdef DM_PARALLEL + call mpi_barrier(comm, ierr) +#endif + + if (trace_use) call da_trace_exit("da_read_obs_ncgoesabi") + +end subroutine da_read_obs_ncgoesabi + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_ichan(channel, channel_list, nchan, ichan) !result(ichan) + + implicit none + + integer, intent(in) :: channel, nchan + integer, intent(in) :: channel_list(nchan) + integer, intent(out) :: ichan + integer :: i + + if (trace_use) call da_trace_entry("get_ichan") + + ichan = 0 + do i = 1, nchan + if (channel .eq. channel_list(i)) then + ichan = i + exit + end if + end do + + if (trace_use) call da_trace_exit("get_ichan") + +end subroutine get_ichan + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_metadata( filename, & + ydim, xdim, req, rpol, pph, nam) !, lat_sat, lon_sat ) + + implicit none + + character(*), intent(in) :: filename + integer, intent(out) :: ydim, xdim + real(r_double), intent(out) :: req, rpol, pph, nam +!!! real, intent(out) :: lat_sat, lon_sat + + integer :: ierr, ncid, varid, dimid + + if (trace_use) call da_trace_entry("get_abil1b_metadata") + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) + + !! Determine ABI satellite parameters (optional outputs) + ierr=nf_inq_dimid(ncid,'y',dimid) + ierr=nf_inq_dimlen(ncid,dimid,ydim) + ierr=nf_inq_dimid(ncid,'x',dimid) + ierr=nf_inq_dimlen(ncid,dimid,xdim) + + ierr=nf_inq_varid(ncid,'goes_imager_projection',varid) + ierr=nf_get_att_double(ncid,varid,'semi_major_axis',req) + ierr=nf_get_att_double(ncid,varid,'semi_minor_axis',rpol) + ierr=nf_get_att_double(ncid,varid,'perspective_point_height',pph) + ierr=nf_get_att_double(ncid,varid,'longitude_of_projection_origin',nam) + nam = nam * deg2rad + +!!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lat',varid) +!!! ierr=nf_get_var_double(ncid,varid,lat_sat) +!!! ierr=nf_inq_varid(ncid,'nominal_satellite_subpoint_lon',varid) +!!! ierr=nf_get_var_double(ncid,varid,lon_sat) + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_metadata") + +end subroutine get_abil1b_metadata + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_grid1( filename, & + ny, nx, & + yy_abi, xx_abi, & + yoff, xoff ) + + implicit none + + character(*), intent(in) :: filename + integer, intent(in) :: ny, nx + real, intent(out) :: yy_abi(ny), xx_abi(nx) + integer, intent(out) :: yoff, xoff + + integer :: ierr, ncid, varid + real :: slp, itp + + if (trace_use) call da_trace_entry("get_abil1b_grid1") + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + call handle_err('Error opening file',ierr) + + ierr=nf_inq_varid(ncid,'y',varid) + + ierr=nf_get_var_double(ncid,varid,yy_abi) + + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) + yy_abi = yy_abi*slp+itp + yoff = floor(itp/slp) + + ierr=nf_inq_varid(ncid,'x',varid) + + ierr=nf_get_var_double(ncid,varid,xx_abi) + + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) + xx_abi = xx_abi*slp+itp + xoff = floor(itp/slp) + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_grid1") + +end subroutine get_abil1b_grid1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_grid2_1d( yy_abi, xx_abi, req, rpol, pph, nam, satellite_id, & + lat, lon, satzen, satazi, & + earthmask, zenmask ) + + implicit none + + real, intent(in) :: yy_abi(:), xx_abi(:) + real(r_double), intent(in) :: req, rpol, pph, nam + integer, intent(in) :: satellite_id + + ! GOES-ABI fields + real, intent(out) :: lat(:), lon(:) + real, intent(out) :: satzen(:), satazi(:) + logical, intent(out) :: earthmask(:), zenmask(:) + + ! Internal Variables + type(info_type) :: info + logical :: outside_all, dummy_bool + + integer :: iy, ix, n + real(r_double) :: hh + real, parameter :: satzen_limit=75.0 + + if (trace_use) call da_trace_entry("get_abil1b_grid2_1d") + + lat = missing_r + lon = missing_r + satzen = missing_r + satazi = missing_r + earthmask=.true. + zenmask=.true. + + hh=pph+req + + call get_abil1b_latlon_1d ( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + where( lat.eq.missing_r .OR. lon.eq.missing_r .OR. & + isnan(lat) .OR. isnan(lon) ) + earthmask = .false. + lat = missing_r + lon = missing_r + end where + + call da_get_sat_angles_1d( lat, lon, satellite_id, satzen, satazi ) + + where ( isnan(satzen) .or. satzen.gt.satzen_limit .or. satzen.eq.missing_r ) + satzen = missing_r + zenmask = .false. + end where + + if (trace_use) call da_trace_exit("get_abil1b_grid2_1d") + +end subroutine get_abil1b_grid2_1d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_rad( filename, ys, ye, xs, xe, radmask, inst, ichan, & + radout, bc1, bc2, fk1, fk2 ) + implicit none + + character(*), intent(in) :: filename + + !Size of full data set + + !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) + integer, intent(in) :: ys, ye, xs, xe + integer, intent(in) :: inst, ichan + + logical, intent(inout) :: radmask( ys:ye, xs:xe ) + real, intent(out) :: radout( ys:ye, xs:xe ) + real, intent(out) :: bc1, bc2, fk1, fk2 + + real :: rad(xs:xe, ys:ye) + integer :: DQF(xs:xe, ys:ye) + + integer :: ierr, ncid, varid + integer :: iy, ix + integer :: nykeep, nxkeep + real :: slp, itp + + if (trace_use) call da_trace_entry("get_abil1b_rad") + + rad = missing_r + + !! Save rad reading time by selecting a subset of netcdf var + nykeep = ye - ys + 1 + nxkeep = xe - xs + 1 + + if (nykeep.le.0 .or. nxkeep.le.0) then + radmask = .false. + return + end if + + ierr=nf_open(trim(filename),nf_nowrite,ncid) + + call handle_err('Error opening file',ierr) + + ierr=nf_inq_varid( ncid, 'Rad', varid ) + ierr=nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), rad ) + ierr=nf_get_att_double(ncid,varid,'scale_factor',slp) + ierr=nf_get_att_double(ncid,varid,'add_offset',itp) + rad=rad*slp+itp + + ierr=nf_inq_varid ( ncid, 'DQF', varid ) + ierr=nf_get_vara_int ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), DQF ) + + ierr=nf_inq_varid( ncid, 'planck_bc1', varid ) + ierr=nf_get_var_double( ncid, varid, bc1 ) + ierr=nf_inq_varid( ncid, 'planck_bc2', varid ) + ierr=nf_get_var_double( ncid, varid, bc2 ) + ierr=nf_inq_varid( ncid, 'planck_fk1', varid ) + ierr=nf_get_var_double( ncid, varid, fk1 ) + ierr=nf_inq_varid( ncid, 'planck_fk2', varid ) + ierr=nf_get_var_double( ncid, varid, fk2 ) + + radmask = ( radmask .and. (transpose(DQF).eq.0 .or. transpose(DQF).eq.1) ) + radmask = ( radmask .and. transpose(rad).gt.0.0 ) + + radout = missing_r + where ( radmask ) + radout = transpose(rad) + end where + + ierr=nf_close(ncid) + call handle_err('Error closing file',ierr) + + if (trace_use) call da_trace_exit("get_abil1b_rad") + +end subroutine get_abil1b_rad + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +elemental function rad2bt( rad, bc1, bc2, fk1, fk2 ) result(bt) + implicit none + + real, intent(in) :: rad + real, intent(in) :: bc1, bc2, fk1, fk2 + + real :: bt + + bt = ( fk2 / ( log(( fk1 / rad ) + 1.0) ) - bc1 ) / bc2 + +end function rad2bt + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +elemental function bt2rad( bt, bc1, bc2, fk1, fk2 ) result(rad) + implicit none + + real, intent(in) :: bt + real, intent(in) :: bc1, bc2, fk1, fk2 + + real :: rad + + rad = fk1 / ( exp( fk2 / (bc1 + bc2 * bt)) - 1.0 ) + +end function bt2rad + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_terr( filename, ys, ye, xs, xe, terr ) + implicit none + + character(*), intent(in) :: filename + + !Size of full data set + + !Starting and stopping indices of this view desired (not equivalent to Full Disk indices) + integer, intent(in) :: ys, ye, xs, xe + real, intent(out) :: terr( ys:ye, xs:xe ) ! unit = meters + + real :: terr_trans( xs:xe, ys:ye ) ! unit = meters + integer :: ncid, varid + integer :: nykeep, nxkeep + real :: terr_miss + + if (trace_use) call da_trace_entry("get_abil1b_terr") + + terr = missing_r + + !! Save rad reading time by selecting a subset of netcdf var + nykeep = ye - ys + 1 + nxkeep = xe - xs + 1 + + if (nykeep.le.0 .or. nxkeep.le.0) then + return + end if + + call handle_err ( 'Error opening file', & + nf_open(trim(filename),nf_nowrite,ncid) ) + call handle_err ( 'Error getting terr ID', & + nf_inq_varid( ncid, 'terr', varid ) ) + + write(*,*) 'DEBUG get_abil1b_terr, xs, ys, xs+nxkeep, ys+nykeep: ',xs,ys,xs+nxkeep,ys+nykeep + + call handle_err ( 'Error reading terrain height', & + nf_get_vara_double ( ncid, varid, (/xs,ys/), (/nxkeep,nykeep/), terr_trans ) ) + terr = transpose(terr_trans) + + call handle_err ( 'Error with _FillValue', & + nf_get_att_double(ncid, varid, '_FillValue', terr_miss) ) + + where ( terr .le. terr_miss ) & + terr = missing_r + + call handle_err('Error closing file', & + nf_close(ncid) ) + + if (trace_use) call da_trace_exit("get_abil1b_terr") + +end subroutine get_abil1b_terr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_latlon_1d( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + implicit none + + real, intent(in) :: yy_abi(:), xx_abi(:) + real, intent(in) :: req, rpol, hh, nam + real, intent(inout) :: lat(:), lon(:) + + real, allocatable :: lat1(:), lon1(:) + real, allocatable :: aa(:), bb(:), cc(:), rs(:), sx(:), sy(:), sz(:) + real, allocatable :: radicand(:) + integer :: n + + if (trace_use) call da_trace_entry("get_abil1b_latlon_1d") + + n = size(yy_abi) + + allocate ( lat1( n ) ) + allocate ( lon1( n ) ) + allocate ( aa( n ) ) + allocate ( bb( n ) ) + allocate ( cc( n ) ) + allocate ( rs( n ) ) + allocate ( sx( n ) ) + allocate ( sy( n ) ) + allocate ( sz( n ) ) + allocate ( radicand( n ) ) + + aa = sin( xx_abi )**2 + cos( xx_abi )**2 * ( cos( yy_abi )**2 + req**2/rpol**2 * sin( yy_abi )**2 ) + + bb = -2.D0 * hh * cos( xx_abi ) * cos( yy_abi ) + + cc = hh**2-req**2 + + radicand = bb ** 2 - 4.D0 * aa * cc + + where ( radicand .ge. 0. ) + rs = ( -bb - sqrt( radicand ) ) / ( 2.D0 * aa ) + sx = rs * cos( xx_abi ) * cos( yy_abi ) + sy = -rs * sin( xx_abi ) + sz = rs * cos( xx_abi ) * sin( yy_abi ) + + lat1 = atan( req**2 / rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) + lon1 = nam - atan( sy / ( hh - sx ) ) + + lat = lat1 / deg2rad + lon = lon1 / deg2rad + end where + + deallocate ( lat1, lon1, aa, bb, cc, rs, sx, sy, sz, radicand ) + + if (trace_use) call da_trace_exit("get_abil1b_latlon_1d") + +end subroutine get_abil1b_latlon_1d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine get_abil1b_latlon( yy_abi, xx_abi, lat, lon, req, rpol, hh, nam ) + + implicit none + + real, intent(in) :: yy_abi, xx_abi + real, intent(in) :: req, rpol, hh, nam + real, intent(inout) :: lat,lon + + real :: lat1,lon1 + real :: aa,bb,cc,rs,sx,sy,sz + real :: radicand + + if (trace_use) call da_trace_entry("get_abil1b_latlon") + + aa = sin( xx_abi )**2 + cos( xx_abi )**2 * ( cos( yy_abi )**2 + req**2/rpol**2 * sin( yy_abi )**2) + bb = -2.D0*hh * cos( xx_abi ) * cos( yy_abi ) + cc = hh**2 - req**2 + + radicand = bb **2 - 4.D0 * aa * cc + if (radicand .lt. 0.) return + + rs = ( -bb - sqrt( radicand ) )/(2.D0 * aa) + sx = rs * cos( xx_abi ) * cos( yy_abi ) + sy = -rs * sin( xx_abi ) + sz = rs * cos( xx_abi ) * sin( yy_abi ) + + lat1 = atan( req**2/rpol**2 * sz / sqrt( ( hh - sx )**2 + sy**2) ) + lon1 = nam-atan( sy / ( hh - sx ) ) + + lat = lat1 / deg2rad + lon = lon1 / deg2rad + + if (trace_use) call da_trace_exit("get_abil1b_latlon") + +end subroutine get_abil1b_latlon + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef DM_PARALLEL +subroutine split_grid( ny_global, nx_global, & + ny_grid, nx_grid, & + ys_grid, xs_grid ) + implicit none + + integer, intent(in) :: ny_global, nx_global + integer, intent(out) :: ny_grid(num_procs), nx_grid(num_procs), & + ys_grid(num_procs), xs_grid(num_procs) + + integer, target :: ny_vec(ntasks_y), ys_vec(ntasks_y) !, ye_vec(ntasks_y) + integer, target :: nx_vec(ntasks_x), xs_vec(ntasks_x) !, xe_vec(ntasks_x) + integer, pointer :: nvec(:), svec(:) + + integer :: mm, i, j, ii, iproc, igrid, ntasks, nglobal, fact + + do igrid = 1, 2 + if (igrid.eq.1) then + nvec => ny_vec + svec => ys_vec + ntasks = ntasks_y + nglobal = ny_global + else if (igrid.eq.2) then + nvec => nx_vec + svec => xs_vec + ntasks = ntasks_x + nglobal = nx_global + end if + + nvec = nglobal / ntasks + mm = mod( nglobal , ntasks ) + do j = 1, ntasks + if ( mm .eq. 0 ) exit + nvec(j) = nvec(j) + 1 + mm = mm - 1 + end do + + svec(1) = 1 + do j = 1, ntasks + if (j .lt. ntasks) then + svec(j+1) = svec(j) + nvec(j) + end if + end do + end do + + iproc = 0 + do j = 1, ntasks_y + do i = 1, ntasks_x + iproc = iproc + 1 + ny_grid(iproc) = ny_vec(j) + ys_grid(iproc) = ys_vec(j) + nx_grid(iproc) = nx_vec(i) + xs_grid(iproc) = xs_vec(i) + end do + end do + +end subroutine split_grid +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine jday2cal(jdy, yr, mt, dy) + implicit none + integer, intent(in) :: jdy, yr + integer, intent(out) :: mt, dy + integer :: d_in_m(12) = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/) + integer :: imonth, tot_days + if ( mod(yr,4).eq.0 .and. .not.(mod(yr,100).eq.0 .and. .not.mod(yr,400).eq.0) ) d_in_m(2) = 29 + tot_days = 0 + do imonth = 1, 12 + tot_days = tot_days + d_in_m(imonth) + if (tot_days .ge. jdy) then + mt = imonth + dy = jdy - ( tot_days - d_in_m(imonth) ) + exit + end if + end do +end subroutine jday2cal + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine da_get_cal_time(jmod,yr,mt,dy,hr,mn,sc) + ! Converts modified Julian time (in minutes) to Gregorian calender date + ! Modified from this code: David G. Simpson, NASA Goddard, Accessed April 2018 + ! https://caps.gsfc.nasa.gov/simpson/software.html + + implicit none + + real(r_double), intent(in) :: jmod + integer, intent(out) :: yr,mt,dy,hr,mn + integer, intent(out), optional :: sc + + real(r_double) :: ju, j0, F + integer :: yr0, sc0 + INTEGER :: A, B, C, D, E, Z, ALPHA ! intermediate variables + real(r_double) :: dd + + ! Conversion to Julian day from MJD reference time: 1978 Jan 01 00:12:00 (see da_get_julian_time) + real(r_double), parameter :: jd_jmod = 2443510.0 + + ! Convert to days + ju = jmod / 1440.D0 + + !! Convert reference MJD to actual Julian time + ju = ju+jd_jmod + Z = INT(ju) + F = ju - Z + + !! Gregorian date test (can probably assume this is a Gregorian date) + IF (Z .LT. 2299161) THEN + A = Z + ELSE + ALPHA = INT((Z-1867216.25D0)/36524.25D0) + A = Z + 1 + ALPHA - ALPHA/4 + END IF + + B = A + 1524 + C = INT((B-122.1D0)/365.25D0) + D = INT(365.25D0*C) + E = INT((B-D)/30.6001D0) + + IF (E .LT. 14) THEN + mt = E - 1 + ELSE + mt = E - 13 + END IF + + IF (mt .GT. 2) THEN + yr = C - 4716 + ELSE + yr = C - 4715 + END IF + + dd = B - D - INT(30.6001D0*E) + F + + dy = floor(dd) + + !! Remainder for hr, mn, sc. + dd = dd - real(dy,8) + + sc0 = nint(dd*86400.) + hr = sc0 / 3600 + sc0 = sc0 - hr*3600 + mn = sc0 / 60 + if (present(sc)) sc = sc0 - mn*60 + +end subroutine da_get_cal_time + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine handle_err(rmarker,nf_status) + implicit none + integer, intent(in) :: nf_status + character*(*), intent(in) :: rmarker + if (nf_status .ne. nf_noerr) then + write(*,*) 'NetCDF error : ',rmarker + write(*,*) ' ',nf_strerror(nf_status) + stop + endif +end subroutine handle_err + diff --git a/var/da/da_radiance/da_rttov.f90 b/var/da/da_radiance/da_rttov.f90 index 46e71c55b5..9bad0db61f 100644 --- a/var/da/da_radiance/da_rttov.f90 +++ b/var/da/da_radiance/da_rttov.f90 @@ -31,9 +31,11 @@ module da_rttov num_fgat_time,stdout,trace_use, use_error_factor_rad, & qc_good, qc_bad,myproc,biascorr, global,ims,ime,jms,jme, & use_clddet, time_slots, rttov_emis_atlas_ir, rttov_emis_atlas_mw, & - use_mspps_emis, use_mspps_ts + use_mspps_emis, use_mspps_ts, use_clddet_zz use da_interpolation, only : da_to_zk_new, & - da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj + da_interp_lin_2d, da_interp_lin_3d, da_interp_lin_3d_adj, da_interp_lin_2d_adj, & + da_interp_2d_partial + use da_physics, only: da_trop_wmo use da_tools_serial, only : da_get_unit, da_free_unit #ifdef DM_PARALLEL use da_par_util, only : true_mpi_real diff --git a/var/da/da_radiance/da_setup_radiance_structures.inc b/var/da/da_radiance/da_setup_radiance_structures.inc index cdf9f9238b..10f5f1c724 100644 --- a/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/var/da/da_radiance/da_setup_radiance_structures.inc @@ -217,6 +217,13 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) !end if !write(unit=stdout,fmt='(a)') 'Finish reading goesimg data' end if + if (use_goesabiobs) then + write(unit=stdout,fmt='(a)') 'Reading netcdf goes ABI radiance data' + + call da_read_obs_ncgoesabi(iv, 16) + + call da_read_obs_ncgoesabi(iv, 17) + end if if (use_gmiobs) then #if defined(HDF5) write(unit=stdout,fmt='(a)') 'Reading GMI data in HDF5 format' diff --git a/var/da/da_radiance/da_write_iv_rad_ascii.inc b/var/da/da_radiance/da_write_iv_rad_ascii.inc index c5a6fa84dd..efb3b2874c 100644 --- a/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -18,7 +18,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) character(len=filename_len) :: filename character(len=7) :: surftype integer :: ndomain - logical :: amsr2, ahi + logical :: amsr2, ahi, abi real :: cip ! to output cloud-ice path integer :: cloudflag ! to output cloudflag integer, dimension(1) :: maxl @@ -59,6 +59,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) endif amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + abi = index(iv%instid(i)%rttovid_string,'abi') > 0 ahi = index(iv%instid(i)%rttovid_string,'ahi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_inv_'//trim(iv%instid(i)%rttovid_string)//'.', myproc @@ -177,7 +178,7 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') ob%instid(i)%tb(:,n) write(unit=innov_rad_unit,fmt='(a)') 'BAK : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb(:,n) - if (rtm_option==rtm_option_crtm .and. crtm_cloud .and. (amsr2 .or. ahi) ) then + if (rtm_option==rtm_option_crtm .and. crtm_cloud .and. (amsr2 .or. ahi .or. abi) ) then write(unit=innov_rad_unit,fmt='(a)') 'BAK_clr : ' write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_xb_clr(:,n) endif @@ -197,6 +198,14 @@ subroutine da_write_iv_rad_ascii (it, ob, iv ) write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=innov_rad_unit,fmt='(a)') 'QC : ' write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs + write(unit=innov_rad_unit,fmt='(a)') 'CMOD : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'COBS : ' + write(unit=innov_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) + write(unit=innov_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=innov_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) + end if if (write_profile) then nlevelss = iv%instid(i)%nlevels diff --git a/var/da/da_radiance/da_write_oa_rad_ascii.inc b/var/da/da_radiance/da_write_oa_rad_ascii.inc index 2f058839df..613cbcf4c5 100644 --- a/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -19,7 +19,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) character(len=filename_len) :: filename character(len=7) :: surftype integer :: ndomain - logical :: amsr2 + logical :: amsr2, abi if (trace_use) call da_trace_entry("da_write_oa_rad_ascii") @@ -40,6 +40,7 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) if (ndomain < 1) cycle amsr2 = index(iv%instid(i)%rttovid_string,'amsr2') > 0 + abi = index(iv%instid(i)%rttovid_string,'abi') > 0 write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_oma_'//trim(iv%instid(i)%rttovid_string)//'.', myproc @@ -141,6 +142,14 @@ subroutine da_write_oa_rad_ascii (it, ob, iv, re ) write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%tb_error(:,n) write(unit=oma_rad_unit,fmt='(a)') 'QC : ' write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%tb_qc(:,n) + if ( abi .and. crtm_cloud ) then ! write out cloud_mod, cloud_obs, cloud_flag + write(unit=oma_rad_unit,fmt='(a)') 'CMOD : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_mod(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'COBS : ' + write(unit=oma_rad_unit,fmt='(10f11.2)') iv%instid(i)%cloud_obs(:,n) + write(unit=oma_rad_unit,fmt='(a)') 'CLOUD : ' + write(unit=oma_rad_unit,fmt='(10i11)') iv%instid(i)%cloud_flag(:,n) + end if if (write_profile) then nlevelss = iv%instid(i)%nlevels diff --git a/var/da/da_radiance/module_radiance.f90 b/var/da/da_radiance/module_radiance.f90 index 2fbfdd0a9c..ba3ad3f581 100644 --- a/var/da/da_radiance/module_radiance.f90 +++ b/var/da/da_radiance/module_radiance.f90 @@ -161,6 +161,8 @@ module module_radiance integer, pointer :: iuse (:) ! usage flag (-1: not use) from radiance info file real , pointer :: error(:) ! error Standard Deviation from radiance info file real , pointer :: error_cld(:) ! error Standard Deviation for cloudy radiance from radiance info file + real , pointer :: error_cld_y(:) ! error Standard Deviation for cloudy radiance from radiance info file, for ABI + real , pointer :: error_cld_x(:) ! error Standard Deviation for cloudy radiance from radiance info file, for ABI real , pointer :: polar(:) ! polarisation (0:ver; 1:hori) from radiance info file real , pointer :: error_factor(:) ! error tuning factor ! from error tuning file ! new air mass bias correction coefs. diff --git a/var/da/da_setup_structures/da_setup_obs_structures.inc b/var/da/da_setup_structures/da_setup_obs_structures.inc index ebbd62457e..e627396308 100644 --- a/var/da/da_setup_structures/da_setup_obs_structures.inc +++ b/var/da/da_setup_structures/da_setup_obs_structures.inc @@ -67,6 +67,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_airsobs = .false. use_eos_amsuaobs = .false. use_hsbobs = .false. + use_ahiobs = .false. + use_mwhs2obs = .false. + use_gmiobs = .false. + use_goesabiobs = .false. use_obsgts = .false. use_rad = .false. use_airsretobs = .false. @@ -75,6 +79,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_radarobs = .false. use_radar_rv = .false. use_radar_rf = .false. + use_lightningobs = .false. + use_lightning_w = .false. + use_lightning_div = .false. + use_lightning_qv = .false. #if (WRF_CHEM == 1) use_chemic_surfobs = .false. #endif @@ -99,7 +107,7 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_ssmisobs .OR. use_hirs4obs .OR. use_mhsobs .OR. use_pseudo_rad .OR. & use_mwtsobs .OR. use_mwhsobs .OR. use_atmsobs .OR. use_simulated_rad .OR. & use_iasiobs .OR. use_seviriobs .OR. use_amsr2obs .OR. use_goesimgobs .OR. & - use_ahiobs .OR. use_mwhs2obs .OR. use_gmiobs) then + use_ahiobs .OR. use_mwhs2obs .OR. use_gmiobs .OR. use_goesabiobs) then use_rad = .true. else use_rad = .false. @@ -150,6 +158,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_airsobs = .false. use_eos_amsuaobs = .false. use_hsbobs = .false. + use_ahiobs = .false. + use_mwhs2obs = .false. + use_gmiobs = .false. + use_goesabiobs = .false. use_obsgts = .false. use_rad = .false. use_airsretobs = .false. @@ -158,6 +170,10 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) use_radarobs = .false. use_radar_rv = .false. use_radar_rf = .false. + use_lightningobs = .false. + use_lightning_w = .false. + use_lightning_div = .false. + use_lightning_qv = .false. #if (WRF_CHEM == 1) use_chemic_surfobs = .false. #endif @@ -188,6 +204,7 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) if ( use_profilerobs ) obs_use(profiler) = .true. if ( use_qscatobs ) obs_use(qscat) = .true. if ( use_radarobs ) obs_use(radar) = .true. + if ( use_lightningobs ) obs_use(lightning) = .true. if ( use_rainobs ) obs_use(rain) = .true. if ( use_satemobs ) obs_use(satem) = .true. if ( use_shipsobs ) obs_use(ships) = .true. @@ -277,6 +294,7 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) thin_conv_opt(radar) = no_thin thin_conv_opt(radiance) = no_thin thin_conv_opt(rain) = no_thin + thin_conv_opt(lightning) = no_thin if ( thin_conv .and. ob_format==ob_format_bufr ) then ! gpsref horizontal thinning is not implemented for bufr input thin_conv_opt(gpsref) = no_thin @@ -392,6 +410,12 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) call da_setup_obs_structures_radar (grid, ob, iv) end if + if (use_lightningobs) then + ! Lightning obs are read from separate file(s) + call da_message((/'Using ASCII format lightning observation input'/)) + call da_setup_obs_structures_lightning (grid, ob, iv) + end if + if (use_rainobs .and. var4d) then call da_message((/'Using ASCII format precipitation observation input'/)) call da_setup_obs_structures_rain (grid, ob, iv) @@ -411,6 +435,15 @@ subroutine da_setup_obs_structures( grid, ob, iv, j_cost) if ( use_amsr2obs ) then call da_message((/'Using AMSR2 radiance input in HDF5 format'/)) end if + if ( use_goesimgobs ) then + call da_message((/'Using GOES IMAGER radiance input in netcdf format'/)) + end if + if ( use_goesabiobs ) then + call da_message((/'Using GOES ABI radiance input in netcdf format'/)) + end if + if ( use_ahiobs ) then + call da_message((/'Using himawari AHI radiance input in netcdf format'/)) + end if if ( use_gmiobs ) then call da_message((/'Using GMI radiance input in HDF5 format'/)) end if diff --git a/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc b/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc index 49fca83d9d..7a0e313a8d 100644 --- a/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc +++ b/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc @@ -81,7 +81,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) endif do i=1,num_ob_indexes - if (i == radar) cycle + if (i == radar .or. i == lightning) cycle iv%info(i)%plocal(iv%time) = iv%info(i)%nlocal iv%info(i)%ptotal(iv%time) = iv%info(i)%ntotal end do @@ -114,7 +114,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) end if do i=1,num_ob_indexes - if (i == radar) cycle + if (i == radar .or. i==lightning) cycle iv%info(i)%thin_ptotal(n) = iv%info(i)%thin_ntotal iv%info(i)%thin_plocal(n) = iv%info(i)%thin_nlocal end do @@ -134,7 +134,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) end if do i=1,num_ob_indexes - if (i == radar) cycle + if (i == radar .or. i == lightning) cycle iv%info(i)%thin_ptotal(iv%time) = iv%info(i)%thin_ntotal iv%info(i)%thin_plocal(iv%time) = iv%info(i)%thin_nlocal end do @@ -154,7 +154,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) if ( thin_conv_ascii ) then do i = 1, num_ob_indexes if ( thin_conv_opt(i) <= no_thin ) cycle - if (i == radar) cycle + if (i == radar .or. i == lightning) cycle if ( iv%info(i)%ntotal > 0 ) then if ( iv%info(i)%nlocal > 0 ) then if ( ANY(iv%info(i)%thinned(:,:)) ) then diff --git a/var/da/da_setup_structures/da_setup_obs_structures_lightning.inc b/var/da/da_setup_structures/da_setup_obs_structures_lightning.inc new file mode 100644 index 0000000000..9bafc27805 --- /dev/null +++ b/var/da/da_setup_structures/da_setup_obs_structures_lightning.inc @@ -0,0 +1,116 @@ +subroutine da_setup_obs_structures_lightning( grid, ob, iv ) + + !------------------------------------------------------------------------- + ! Purpose: Define, allocate and read lightning observation structure. + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !------------------------------------------------------------------------- + + implicit none + + type (y_type), intent(out) :: ob ! Observation structure. + type (iv_type), intent(inout) :: iv ! O-B structure. + type (domain), intent(inout) :: grid ! First guess structure + + character(len=filename_len) :: filename + integer :: n, i, j, k + integer :: istart,iend,jstart,jend + real :: rlonlat(4) + + if (trace_use) call da_trace_entry("da_setup_obs_structures_lightning") + + call init_constants_derived + + !-------------------------------------------------------------------------- + ! [1.0] Scan lightning observation header and get number of obs: + !-------------------------------------------------------------------------- + if (num_fgat_time > 1) then + do n=1, num_fgat_time + + iv%time = n + filename = ' ' + + ! scan lightning observation file + write(filename(1:10), fmt='(a, i2.2, a)') 'ob', n,'.lightning' + call da_scan_obs_lightning(iv, filename, grid) + + iv%info(lightning)%plocal(n) = iv%info(lightning)%nlocal + iv%info(lightning)%ptotal(n) = iv%info(lightning)%ntotal + end do + else + iv%time = 1 + ! scan main body of lightning observation file + call da_scan_obs_lightning(iv, 'ob.lightning', grid) + iv%info(lightning)%plocal(iv%time) = iv%info(lightning)%nlocal + iv%info(lightning)%ptotal(iv%time) = iv%info(lightning)%ntotal + end if + + !-------------------------------------------------------------------------- + ! Allocate based on input number of obs: + !-------------------------------------------------------------------------- + ! This logic was originally found in da_allocate_observations; moved here + if (iv%info(lightning)%nlocal > 0) allocate(iv%lightning (1:iv%info(lightning)%nlocal)) + if (iv%info(lightning)%nlocal > 0) then + allocate (iv%info(lightning)%name(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%platform(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%id(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%date_char(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%levels(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%lat(iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%lon(iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%elv(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%pstar(iv%info(lightning)%nlocal)) + + allocate (iv%info(lightning)%slp(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%pw(iv%info(lightning)%nlocal)) + + allocate (iv%info(lightning)%x (kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%y (kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%i (kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%j (kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%dx (kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%dxm(kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%dy (kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%dym(kms:kme,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%k (iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%dz (iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%dzm(iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%zk (iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%proc_domain(iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%obs_global_index(iv%info(lightning)%nlocal)) + allocate (iv%info(lightning)%thinned(iv%info(lightning)%max_lev,iv%info(lightning)%nlocal)) + + iv%info(lightning)%proc_domain(:,:) = .false. + iv%info(lightning)%thinned(:,:) = .false. + iv%info(lightning)%zk(:,:) = missing_r + end if + + if (num_fgat_time > 1) then + + do n=1, num_fgat_time + iv%time = n + filename = ' ' + + ! read lightning observation file + write(filename(1:10), fmt='(a, i2.2, a)') 'ob', n,'.lightning' + call da_read_obs_lightning(iv, filename, grid) + + end do + else + iv%time = 1 + + ! read lightning observation file + call da_read_obs_lightning(iv, 'ob.lightning', grid) + end if + + !-------------------------------------------------------------------------- + ! [3.0] Calculate innovation vector (O-B) and create (smaller) ob structure: + !-------------------------------------------------------------------------- + + call da_fill_obs_structures_lightning(iv, ob) + + iv%time = 1 + + if (trace_use) call da_trace_exit("da_setup_obs_structures_lightning") +end subroutine da_setup_obs_structures_lightning + + diff --git a/var/da/da_setup_structures/da_setup_structures.f90 b/var/da/da_setup_structures/da_setup_structures.f90 index 582a14a112..c94e5daf06 100644 --- a/var/da/da_setup_structures/da_setup_structures.f90 +++ b/var/da/da_setup_structures/da_setup_structures.f90 @@ -14,15 +14,15 @@ module da_setup_structures #endif multi_level_type,each_level_type, da_allocate_observations_rain use da_define_structures, only : da_allocate_obs_info, da_allocate_y, da_allocate_y_radar, & - da_allocate_y_rain + da_allocate_y_rain, da_allocate_y_lightning use da_wrf_interfaces, only : wrf_debug, & wrf_dm_bcast_string, wrf_dm_bcast_integer, wrf_dm_bcast_real use da_control, only : trace_use,vert_evalue,stdout,rootproc, myproc, & analysis_date,coarse_ix,coarse_ds,map_projection,coarse_jy, c2,dsm,phic, & pole, cone_factor, start_x,base_pres,ptop,psi1,start_y, base_lapse,base_temp,truelat2_3dv, & truelat1_3dv,xlonc,t0,num_fft_factors,pi,print_detail_spectral, global, print_detail_obs, & - use_radar_rf, use_radar_rhv, use_radar_rqv, radar_rf_opt, & - num_ob_indexes,kts, kte, time_window_max, time_window_min, & + use_radar_rf, use_radar_rhv, use_radar_rqv, radar_rf_opt, use_lightning_w, use_lightning_div, & + use_lightning_qv, num_ob_indexes,kts, kte, time_window_max, time_window_min, & max_fgat_time, num_fgat_time, dt_cloud_model, & use_ssmiretrievalobs,use_radarobs,use_ssmitbobs,use_qscatobs, num_procs, use_rainobs, & #if (WRF_CHEM == 1) @@ -32,7 +32,7 @@ module da_setup_structures num_pseudo, missing, ob_format, ob_format_bufr,ob_format_ascii, ob_format_madis, ob_format_gpsro, & use_airepobs, use_tamdarobs, test_dm_exact, use_amsuaobs, use_amsubobs, & use_airsobs, use_bogusobs, sfc_assi_options, use_eos_amsuaobs, & - use_filtered_rad, use_gpsrefobs, use_hirs2obs, & + use_filtered_rad, use_gpsrefobs, use_hirs2obs, use_lightningobs, & use_hsbobs,use_hirs3obs, use_gpspwobs, use_gpsztdobs, use_metarobs, use_msuobs, & use_kma1dvar,use_pilotobs, use_polaramvobs, use_rad, crtm_cloud, use_soundobs,use_mtgirsobs, & use_ssmt1obs,use_ssmt2obs, use_shipsobs, use_satemobs, use_synopobs, & @@ -57,7 +57,7 @@ module da_setup_structures vert_corr_2, alphacv_method_xa, vert_evalue_global, & vert_evalue_local, obs_names, thin_conv, thin_conv_ascii, & sound, sonde_sfc, mtgirs, tamdar, tamdar_sfc, synop, profiler, gpsref, gpspw, polaramv, geoamv, ships, metar, & - satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, rain, & + satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, rain, lightning, & bogus, buoy, qscat, radiance, pseudo, trace_use_dull, kts,kte, & use_simulated_rad, use_pseudo_rad, pseudo_rad_platid, pseudo_rad_satid, & pseudo_rad_senid, rtminit_nsensor, rtminit_platform, rtminit_satid, & @@ -74,7 +74,7 @@ module da_setup_structures chi_u_t_factor, chi_u_ps_factor,chi_u_rh_factor, t_u_rh_factor, ps_u_rh_factor, & interpolate_stats, be_eta, thin_rainobs, fgat_rain_flags, use_iasiobs, & use_seviriobs, jds_int, jde_int, anal_type_hybrid_dual_res, use_amsr2obs, nrange, use_4denvar, & - use_goesimgobs, use_ahiobs,use_gmiobs, obs_use, thin_conv_opt, no_thin, & + use_goesimgobs, use_ahiobs, use_goesabiobs, use_gmiobs, obs_use, thin_conv_opt, no_thin, & thin_superob_hv, thin_mesh_vert_conv, use_satwnd_bufr use da_control, only: rden_bin, use_lsac use da_control, only: use_cv_w @@ -89,11 +89,13 @@ module da_setup_structures #if (WRF_CHEM == 1) da_fill_obs_structures_chem_sfc, & #endif - da_fill_obs_structures_rain, da_fill_obs_structures_radar, da_set_obs_missing,da_set_3d_obs_missing + da_fill_obs_structures_rain, da_fill_obs_structures_radar, da_fill_obs_structures_lightning, & + da_set_obs_missing, da_set_3d_obs_missing use da_obs_io, only : da_read_obs_bufr,da_read_obs_radar, & da_scan_obs_radar,da_scan_obs_ascii,da_read_obs_ascii, & da_read_obs_bufrgpsro, da_scan_obs_rain, da_read_obs_rain, & da_read_obs_lsac, da_scan_obs_lsac, da_read_obs_bufrgpsro_eph, & + da_read_obs_lightning, da_scan_obs_lightning, & da_read_obs_bufr_satwnd, oetab #if (WRF_CHEM == 1) use da_obs_io, only : da_read_obs_chem_sfc, da_scan_obs_chem_sfc @@ -155,6 +157,7 @@ module da_setup_structures #include "da_setup_obs_structures_madis.inc" #include "da_setup_obs_structures_rain.inc" #include "da_setup_obs_structures_radar.inc" +#include "da_setup_obs_structures_lightning.inc" #include "da_setup_pseudo_obs.inc" #if (WRF_CHEM == 1) #include "da_setup_obs_structures_chem_sfc.inc" diff --git a/var/da/da_statistics/da_analysis_stats.inc b/var/da/da_statistics/da_analysis_stats.inc index 672946b14e..7ac2c831b2 100644 --- a/var/da/da_statistics/da_analysis_stats.inc +++ b/var/da/da_statistics/da_analysis_stats.inc @@ -29,7 +29,7 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR integer :: kdim ! k range real :: um, vm, tm, pm, qm , qcwm, qrnm ! On local domain. - real :: qcim, qsnm, qgrm + real :: qcim, qsnm, qgrm, wm real :: rij_g, rijk_g ! On global domain. type (maxmin_field_type) :: max_u(kts:kte), max_v(kts:kte), & @@ -45,6 +45,8 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR min_qcw(kts:kte), min_qrn(kts:kte), & min_qci(kts:kte), min_qsn(kts:kte), & min_qgr(kts:kte) + type (maxmin_field_type) :: max_w(kts:kte), min_w(kts:kte) + #if (WRF_CHEM == 1) type (maxmin_field_type) :: max_chem(kts:kte,num_chem), min_chem(kts:kte,num_chem) real :: chemm(num_chem), chemv(kts:kte,num_chem) @@ -57,6 +59,7 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR real :: qcwv(kts:kte), qrnv(kts:kte), & qciv(kts:kte), qsnv(kts:kte), & qgrv(kts:kte) + real :: wv(kts:kte) call da_trace_entry("da_analysis_stats") @@ -70,40 +73,78 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR if (rootproc) then write(unit=stats_unit, fmt='(/a/)') ' Minimum of gridded analysis increments' - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(6a/)') & - ' Lvl ', & - 'u i j ', & - 'v i j ', & - 't i j ', & - 'p i j ', & - 'q i j' - case ( 1 ) - write(unit=stats_unit, fmt='(8a/)') & - ' Lvl ', & - 'u i j ', & - 'v i j ', & - 't i j ', & - 'p i j ', & - 'q i j ', & - 'qcw i j ', & - 'qrn i j' - case ( 2, 3 ) - write(unit=stats_unit, fmt='(11a/)') & - ' Lvl ', & - 'u i j ', & - 'v i j ', & - 't i j ', & - 'p i j ', & - 'q i j ', & - 'qcw i j ', & - 'qrn i j ', & - 'qci i j ', & - 'qsn i j ', & - 'qgr i j' - end select - + if (use_cv_w) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(7a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 'w i j ', & + 't i j ', & + 'p i j ', & + 'q i j' + case ( 1 ) + write(unit=stats_unit, fmt='(9a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 'w i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(12a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 'w i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j ', & + 'qci i j ', & + 'qsn i j ', & + 'qgr i j' + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(6a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 't i j ', & + 'p i j ', & + 'q i j' + case ( 1 ) + write(unit=stats_unit, fmt='(8a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(11a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j ', & + 'qci i j ', & + 'qsn i j ', & + 'qgr i j' + end select + end if #if (WRF_CHEM == 1) write(unit=stats_unit2, fmt='(/a/)') ' Minimum of gridded analysis increments' select case ( chem_cv_options ) @@ -162,6 +203,11 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR call da_proc_maxmin_combine(kdim, max_qgr, min_qgr) end if + if ( use_cv_w ) then + call da_maxmin_in_field(grid%xa%w(its:ite,jts:jte,kts:kte), max_w, min_w) + call da_proc_maxmin_combine(kdim, max_w, min_w) + end if + #if (WRF_CHEM == 1) if ( chem_cv_options >= 10 ) then do ic=PARAM_FIRST_SCALAR, num_chem @@ -183,6 +229,8 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR qsnm = 999999.0 qgrm = 999999.0 + wm = 999999.0 + #if (WRF_CHEM == 1) chemm = 999999.0 #endif @@ -190,20 +238,35 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR do k = kts, kte if (rootproc) then if ( abs(min_q(k)%value) < 1.e-30 ) min_q(k)%value = 0.0 - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),e12.4,2i5)') k, & - min_u(k), min_v(k), min_t(k), min_p(k), min_q(k) - case ( 1 ) - write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),3(e12.4,2i5))') k, & - min_u(k), min_v(k), min_t(k), min_p(k), min_q(k), & - min_qcw(k), min_qrn(k) - case ( 2, 3 ) - write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),6(e12.4,2i5))') k, & - min_u(k), min_v(k), min_t(k), min_p(k), min_q(k), & - min_qcw(k), min_qrn(k), min_qci(k), min_qsn(k), min_qgr(k) - end select - + if (use_cv_w) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,5(f12.4,2i5),e12.4,2i5)') k, & + min_u(k), min_v(k), min_w(k), min_t(k), min_p(k), min_q(k) + case ( 1 ) + write(unit=stats_unit, fmt='(i4,5(f12.4,2i5),3(e12.4,2i5))') k, & + min_u(k), min_v(k), min_w(k), min_t(k), min_p(k), min_q(k), & + min_qcw(k), min_qrn(k) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,5(f12.4,2i5),6(e12.4,2i5))') k, & + min_u(k), min_v(k), min_w(k), min_t(k), min_p(k), min_q(k), & + min_qcw(k), min_qrn(k), min_qci(k), min_qsn(k), min_qgr(k) + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),e12.4,2i5)') k, & + min_u(k), min_v(k), min_t(k), min_p(k), min_q(k) + case ( 1 ) + write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),3(e12.4,2i5))') k, & + min_u(k), min_v(k), min_t(k), min_p(k), min_q(k), & + min_qcw(k), min_qrn(k) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),6(e12.4,2i5))') k, & + min_u(k), min_v(k), min_t(k), min_p(k), min_q(k), & + min_qcw(k), min_qrn(k), min_qci(k), min_qsn(k), min_qgr(k) + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) case ( 10 ) @@ -241,6 +304,9 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR qsnm=minval(min_qsn(:)%value) qgrm=minval(min_qgr(:)%value) end if + if ( use_cv_w ) then + wm=minval(min_w(:)%value) + end if end do #if (WRF_CHEM == 1) @@ -250,17 +316,31 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR #endif if (rootproc) then - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(a,4(f12.4,10x),e12.4)') ' ALL', & - um, vm, tm, pm, qm - case ( 1 ) - write(unit=stats_unit, fmt='(a,4(f12.4,10x),3(e12.4,10x))') ' ALL', & - um, vm, tm, pm, qm, qcwm, qrnm - case ( 2, 3 ) - write(unit=stats_unit, fmt='(a,4(f12.4,10x),6(e12.4,10x))') ' ALL', & - um, vm, tm, pm, qm, qcwm, qrnm, qcim, qsnm, qgrm - end select + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,5(f12.4,10x),e12.4)') ' ALL', & + um, vm, wm, tm, pm, qm + case ( 1 ) + write(unit=stats_unit, fmt='(a,5(f12.4,10x),3(e12.4,10x))') ' ALL', & + um, vm, wm, tm, pm, qm, qcwm, qrnm + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,5(f12.4,10x),6(e12.4,10x))') ' ALL', & + um, vm, wm, tm, pm, qm, qcwm, qrnm, qcim, qsnm, qgrm + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,4(f12.4,10x),e12.4)') ' ALL', & + um, vm, tm, pm, qm + case ( 1 ) + write(unit=stats_unit, fmt='(a,4(f12.4,10x),3(e12.4,10x))') ' ALL', & + um, vm, tm, pm, qm, qcwm, qrnm + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,4(f12.4,10x),6(e12.4,10x))') ' ALL', & + um, vm, tm, pm, qm, qcwm, qrnm, qcim, qsnm, qgrm + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) @@ -305,57 +385,112 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR end select #endif - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(6a/)') & - ' Lvl ', & - 'u i j ', & - 'v i j ', & - 't i j ', & - 'p i j ', & - 'q i j' - case ( 1 ) - write(unit=stats_unit, fmt='(8a/)') & - ' Lvl ', & - 'u i j ', & - 'v i j ', & - 't i j ', & - 'p i j ', & - 'q i j ', & - 'qcw i j ', & - 'qrn i j' - case ( 2, 3 ) - write(unit=stats_unit, fmt='(11a/)') & - ' Lvl ', & - 'u i j ', & - 'v i j ', & - 't i j ', & - 'p i j ', & - 'q i j ', & - 'qcw i j ', & - 'qrn i j ', & - 'qci i j ', & - 'qsn i j ', & - 'qgr i j' - end select - end if !rootproc - - do k = kts, kte - if (rootproc) then - if ( abs(max_q(k)%value) < 1.e-30 ) max_q(k)%value = 0.0 + if (use_cv_w) then select case ( cloud_cv_options ) case ( 0 ) - write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),e12.4,2i5)') k, & - max_u(k), max_v(k), max_t(k), max_p(k), max_q(k) + write(unit=stats_unit, fmt='(7a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 'w i j ', & + 't i j ', & + 'p i j ', & + 'q i j' case ( 1 ) - write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),3(e12.4,2i5))') k, & - max_u(k), max_v(k), max_t(k), max_p(k), max_q(k), & - max_qcw(k), max_qrn(k) + write(unit=stats_unit, fmt='(9a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 'w i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j' case ( 2, 3 ) - write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),6(e12.4,2i5))') k, & - max_u(k), max_v(k), max_t(k), max_p(k), max_q(k), & - max_qcw(k), max_qrn(k), max_qci(k), max_qsn(k), max_qgr(k) + write(unit=stats_unit, fmt='(12a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 'w i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j ', & + 'qci i j ', & + 'qsn i j ', & + 'qgr i j' end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(6a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 't i j ', & + 'p i j ', & + 'q i j' + case ( 1 ) + write(unit=stats_unit, fmt='(8a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(11a/)') & + ' Lvl ', & + 'u i j ', & + 'v i j ', & + 't i j ', & + 'p i j ', & + 'q i j ', & + 'qcw i j ', & + 'qrn i j ', & + 'qci i j ', & + 'qsn i j ', & + 'qgr i j' + end select + end if + end if !rootproc + + do k = kts, kte + if (rootproc) then + if ( abs(max_q(k)%value) < 1.e-30 ) max_q(k)%value = 0.0 + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,5(f12.4,2i5),e12.4,2i5)') k, & + max_u(k), max_v(k), max_w(k), max_t(k), max_p(k), max_q(k) + case ( 1 ) + write(unit=stats_unit, fmt='(i4,5(f12.4,2i5),3(e12.4,2i5))') k, & + max_u(k), max_v(k), max_w(k), max_t(k), max_p(k), max_q(k), & + max_qcw(k), max_qrn(k) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,5(f12.4,2i5),6(e12.4,2i5))') k, & + max_u(k), max_v(k), max_w(k), max_t(k), max_p(k), max_q(k), & + max_qcw(k), max_qrn(k), max_qci(k), max_qsn(k), max_qgr(k) + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),e12.4,2i5)') k, & + max_u(k), max_v(k), max_t(k), max_p(k), max_q(k) + case ( 1 ) + write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),3(e12.4,2i5))') k, & + max_u(k), max_v(k), max_t(k), max_p(k), max_q(k), & + max_qcw(k), max_qrn(k) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,4(f12.4,2i5),6(e12.4,2i5))') k, & + max_u(k), max_v(k), max_t(k), max_p(k), max_q(k), & + max_qcw(k), max_qrn(k), max_qci(k), max_qsn(k), max_qgr(k) + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) @@ -394,6 +529,9 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR qsnm=maxval(max_qsn(:)%value) qgrm=maxval(max_qgr(:)%value) end if + if (use_cv_w) then + wm=maxval(max_w(:)%value) + end if end do #if (WRF_CHEM == 1) @@ -403,18 +541,31 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR #endif if (rootproc) then - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(a,4(f12.4,10x),e12.4)') ' ALL', & - um, vm, tm, pm, qm - case ( 1 ) - write(unit=stats_unit, fmt='(a,4(f12.4,10x),3(e12.4,10x))') ' ALL', & - um, vm, tm, pm, qm, qcwm, qrnm - case ( 2, 3 ) - write(unit=stats_unit, fmt='(a,4(f12.4,10x),6(e12.4,10x))') ' ALL', & - um, vm, tm, pm, qm, qcwm, qrnm, qcim, qsnm, qgrm - end select - + if (use_cv_w) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,5(f12.4,10x),e12.4)') ' ALL', & + um, vm, wm, tm, pm, qm + case ( 1 ) + write(unit=stats_unit, fmt='(a,5(f12.4,10x),3(e12.4,10x))') ' ALL', & + um, vm, wm, tm, pm, qm, qcwm, qrnm + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,5(f12.4,10x),6(e12.4,10x))') ' ALL', & + um, vm, wm, tm, pm, qm, qcwm, qrnm, qcim, qsnm, qgrm + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,4(f12.4,10x),e12.4)') ' ALL', & + um, vm, tm, pm, qm + case ( 1 ) + write(unit=stats_unit, fmt='(a,4(f12.4,10x),3(e12.4,10x))') ' ALL', & + um, vm, tm, pm, qm, qcwm, qrnm + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,4(f12.4,10x),6(e12.4,10x))') ' ALL', & + um, vm, tm, pm, qm, qcwm, qrnm, qcim, qsnm, qgrm + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) case ( 10 ) @@ -447,17 +598,31 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR end select #endif - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(a/)') & - ' Lvl u v t p q' - case ( 1 ) - write(unit=stats_unit, fmt='(a/)') & - ' Lvl u v t p q qcw qrn' - case ( 2, 3 ) - write(unit=stats_unit, fmt='(a/)') & - ' Lvl u v t p q qcw qrn qci qsn qgr' - end select + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v w t p q' + case ( 1 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v w t p q qcw qrn' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v w t p q qcw qrn qci qsn qgr' + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v t p q' + case ( 1 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v t p q qcw qrn' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v t p q qcw qrn qci qsn qgr' + end select + end if end if !rootproc um = 0.0 @@ -515,26 +680,54 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR call da_proc_sum_real (qgrv) end if + if ( use_cv_w ) then + wm = 0.0 + do k = kts, kte + wv(k) = sum(grid%xa%w(its:ite,jts:jte,k)) + end do + call da_proc_sum_real (wv) + end if + if (rootproc) then do k = kts, kte - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(i4,4f12.4,e12.4)') k, & - uv(k)*rij_g, vv(k)*rij_g, tv(k)*rij_g, & - pv(k)*rij_g, qv(k)*rij_g - case ( 1 ) - write(unit=stats_unit, fmt='(i4,4f12.4,3e12.4)') k, & - uv(k)*rij_g, vv(k)*rij_g, tv(k)*rij_g, & - pv(k)*rij_g, qv(k)*rij_g, & - qcwv(k)*rij_g, qrnv(k)*rij_g - case ( 2, 3 ) - write(unit=stats_unit, fmt='(i4,4f12.4,6e12.4)') k, & - uv(k)*rij_g, vv(k)*rij_g, tv(k)*rij_g, & - pv(k)*rij_g, qv(k)*rij_g, & - qcwv(k)*rij_g, qrnv(k)*rij_g, qciv(k)*rij_g, & - qsnv(k)*rij_g, qgrv(k)*rij_g - end select - + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,5f12.4,e12.4)') k, & + uv(k)*rij_g, vv(k)*rij_g, wv(k)*rij_g, & + tv(k)*rij_g, pv(k)*rij_g, qv(k)*rij_g + case ( 1 ) + write(unit=stats_unit, fmt='(i4,5f12.4,3e12.4)') k, & + uv(k)*rij_g, vv(k)*rij_g, wv(k)*rij_g, & + tv(k)*rij_g, pv(k)*rij_g, qv(k)*rij_g, & + qcwv(k)*rij_g, qrnv(k)*rij_g + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,5f12.4,6e12.4)') k, & + uv(k)*rij_g, vv(k)*rij_g, wv(k)*rij_g, & + tv(k)*rij_g, pv(k)*rij_g, qv(k)*rij_g, & + qcwv(k)*rij_g, qrnv(k)*rij_g, qciv(k)*rij_g, & + qsnv(k)*rij_g, qgrv(k)*rij_g + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,4f12.4,e12.4)') k, & + uv(k)*rij_g, vv(k)*rij_g, tv(k)*rij_g, & + pv(k)*rij_g, qv(k)*rij_g + case ( 1 ) + write(unit=stats_unit, fmt='(i4,4f12.4,3e12.4)') k, & + uv(k)*rij_g, vv(k)*rij_g, tv(k)*rij_g, & + pv(k)*rij_g, qv(k)*rij_g, & + qcwv(k)*rij_g, qrnv(k)*rij_g + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,4f12.4,6e12.4)') k, & + uv(k)*rij_g, vv(k)*rij_g, tv(k)*rij_g, & + pv(k)*rij_g, qv(k)*rij_g, & + qcwv(k)*rij_g, qrnv(k)*rij_g, qciv(k)*rij_g, & + qsnv(k)*rij_g, qgrv(k)*rij_g + end select + end if + #if (WRF_CHEM == 1) select case ( chem_cv_options ) case ( 10 ) @@ -576,23 +769,42 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR qsnm = qsnm + qsnv(k) qgrm = qgrm + qgrv(k) end if + if ( use_cv_w ) then + wm=wm+wv(k) + end if end do !k loop end if !rootproc if (rootproc) then - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(a,4f12.4,e12.4)') ' ALL', & - um*rijk_g, vm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g - case ( 1 ) - write(unit=stats_unit, fmt='(a,4f12.4,3e12.4)') ' ALL', & - um*rijk_g, vm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g, & - qcwm*rijk_g, qrnm*rijk_g - case ( 2, 3 ) - write(unit=stats_unit, fmt='(a,4f12.4,6e12.4)') ' ALL', & - um*rijk_g, vm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g, & - qcwm*rijk_g, qrnm*rijk_g, qcim*rijk_g, qsnm*rijk_g, qgrm*rijk_g - end select + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,6f12.4,e12.4)') k, & + um*rijk_g, vm*rijk_g, wm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g + case ( 1 ) + write(unit=stats_unit, fmt='(i4,6f12.4,3e12.4)') k, & + um*rijk_g, vm*rijk_g, wm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g, & + qcwm*rijk_g, qrnm*rijk_g + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,5f12.4,6e12.4)') k, & + um*rijk_g, vm*rijk_g, wm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g, & + qcwm*rijk_g, qrnm*rijk_g, qcim*rijk_g, qsnm*rijk_g, qgrm*rijk_g + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,4f12.4,e12.4)') ' ALL', & + um*rijk_g, vm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g + case ( 1 ) + write(unit=stats_unit, fmt='(a,4f12.4,3e12.4)') ' ALL', & + um*rijk_g, vm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g, & + qcwm*rijk_g, qrnm*rijk_g + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,4f12.4,6e12.4)') ' ALL', & + um*rijk_g, vm*rijk_g, tm*rijk_g, pm*rijk_g, qm*rijk_g, & + qcwm*rijk_g, qrnm*rijk_g, qcim*rijk_g, qsnm*rijk_g, qgrm*rijk_g + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) @@ -628,26 +840,43 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR end select #endif - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(a/)') & - ' Lvl u v t p q' - case ( 1 ) - write(unit=stats_unit, fmt='(a/)') & - ' Lvl u v t p q qcw qrn' - case ( 2, 3 ) - write(unit=stats_unit, fmt='(a/)') & - ' Lvl u v t p q qcw qrn qci qsn qgr' - end select + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v w t p q' + case ( 1 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v w t p q qcw qrn' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v w t p q qcw qrn qci qsn qgr' + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v t p q' + case ( 1 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v t p q qcw qrn' + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a/)') & + ' Lvl u v t p q qcw qrn qci qsn qgr' + end select + end if + end if !rootproc um = 0.0 vm = 0.0 + wm = 0.0 tm = 0.0 pm = 0.0 qm = 0.0 uv = 0.0 vv = 0.0 + wv = 0.0 tv = 0.0 pv = 0.0 qv = 0.0 @@ -725,40 +954,86 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR call da_proc_sum_real (qsnv) call da_proc_sum_real (qgrv) end if + + if ( use_cv_w ) then + do k = kts, kte + do j=jts,jte + do i=its,ite + wv(k) = wv(k) + grid%xa%w(i,j,k) * grid%xa%w(i,j,k) + end do + end do + end do + call da_proc_sum_real (wv) + end if if (rootproc) then do k = kts, kte - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(i4,4f12.4,e12.4)') k, & - sqrt(uv(k)*rij_g), & - sqrt(vv(k)*rij_g), & - sqrt(tv(k)*rij_g), & - sqrt(pv(k)*rij_g), & - sqrt(qv(k)*rij_g) - case ( 1 ) - write(unit=stats_unit, fmt='(i4,4f12.4,3e12.4)') k, & - sqrt(uv(k)*rij_g), & - sqrt(vv(k)*rij_g), & - sqrt(tv(k)*rij_g), & - sqrt(pv(k)*rij_g), & - sqrt(qv(k)*rij_g), & - sqrt(qcwv(k)*rij_g), & - sqrt(qrnv(k)*rij_g) - case ( 2, 3 ) - write(unit=stats_unit, fmt='(i4,4f12.4,6e12.4)') k, & - sqrt(uv(k)*rij_g), & - sqrt(vv(k)*rij_g), & - sqrt(tv(k)*rij_g), & - sqrt(pv(k)*rij_g), & - sqrt(qv(k)*rij_g), & - sqrt(qcwv(k)*rij_g), & - sqrt(qrnv(k)*rij_g), & - sqrt(qciv(k)*rij_g), & - sqrt(qsnv(k)*rij_g), & - sqrt(qgrv(k)*rij_g) - end select - + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,5f12.4,e12.4)') k, & + sqrt(uv(k)*rij_g), & + sqrt(vv(k)*rij_g), & + sqrt(wv(k)*rij_g), & + sqrt(tv(k)*rij_g), & + sqrt(pv(k)*rij_g), & + sqrt(qv(k)*rij_g) + case ( 1 ) + write(unit=stats_unit, fmt='(i4,5f12.4,3e12.4)') k, & + sqrt(uv(k)*rij_g), & + sqrt(vv(k)*rij_g), & + sqrt(wv(k)*rij_g), & + sqrt(tv(k)*rij_g), & + sqrt(pv(k)*rij_g), & + sqrt(qv(k)*rij_g), & + sqrt(qcwv(k)*rij_g), & + sqrt(qrnv(k)*rij_g) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,5f12.4,6e12.4)') k, & + sqrt(uv(k)*rij_g), & + sqrt(vv(k)*rij_g), & + sqrt(wv(k)*rij_g), & + sqrt(tv(k)*rij_g), & + sqrt(pv(k)*rij_g), & + sqrt(qv(k)*rij_g), & + sqrt(qcwv(k)*rij_g), & + sqrt(qrnv(k)*rij_g), & + sqrt(qciv(k)*rij_g), & + sqrt(qsnv(k)*rij_g), & + sqrt(qgrv(k)*rij_g) + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(i4,4f12.4,e12.4)') k, & + sqrt(uv(k)*rij_g), & + sqrt(vv(k)*rij_g), & + sqrt(tv(k)*rij_g), & + sqrt(pv(k)*rij_g), & + sqrt(qv(k)*rij_g) + case ( 1 ) + write(unit=stats_unit, fmt='(i4,4f12.4,3e12.4)') k, & + sqrt(uv(k)*rij_g), & + sqrt(vv(k)*rij_g), & + sqrt(tv(k)*rij_g), & + sqrt(pv(k)*rij_g), & + sqrt(qv(k)*rij_g), & + sqrt(qcwv(k)*rij_g), & + sqrt(qrnv(k)*rij_g) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(i4,4f12.4,6e12.4)') k, & + sqrt(uv(k)*rij_g), & + sqrt(vv(k)*rij_g), & + sqrt(tv(k)*rij_g), & + sqrt(pv(k)*rij_g), & + sqrt(qv(k)*rij_g), & + sqrt(qcwv(k)*rij_g), & + sqrt(qrnv(k)*rij_g), & + sqrt(qciv(k)*rij_g), & + sqrt(qsnv(k)*rij_g), & + sqrt(qgrv(k)*rij_g) + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) case ( 10 ) @@ -805,27 +1080,50 @@ use module_state_description, only : num_chem, PARAM_FIRST_SCALAR qcim=qcim+qciv(k) qsnm=qsnm+qsnv(k) end if + if ( use_cv_w ) then + wm=wm+wv(k) + end if end do !k loop end if !rootproc if (rootproc) then - select case ( cloud_cv_options ) - case ( 0 ) - write(unit=stats_unit, fmt='(a,4f12.4,e12.4)') ' ALL', & - sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(tm*rijk_g), & - sqrt(pm*rijk_g), sqrt(qm*rijk_g) - case ( 1 ) - write(unit=stats_unit, fmt='(a,4f12.4,3e12.4)') ' ALL', & - sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(tm*rijk_g), & - sqrt(pm*rijk_g), sqrt(qm*rijk_g), & - sqrt(qcwm*rijk_g), sqrt(qrnm*rijk_g) - case ( 2, 3 ) - write(unit=stats_unit, fmt='(a,4f12.4,6e12.4)') ' ALL', & - sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(tm*rijk_g), & - sqrt(pm*rijk_g), sqrt(qm*rijk_g), & - sqrt(qcwm*rijk_g), sqrt(qrnm*rijk_g), sqrt(qcim*rijk_g), & - sqrt(qsnm*rijk_g), sqrt(qgrm*rijk_g) - end select + if ( use_cv_w ) then + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,5f12.4,e12.4)') ' ALL', & + sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(wm*rijk_g), & + sqrt(tm*rijk_g), sqrt(pm*rijk_g), sqrt(qm*rijk_g) + case ( 1 ) + write(unit=stats_unit, fmt='(a,5f12.4,3e12.4)') ' ALL', & + sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(wm*rijk_g), & + sqrt(tm*rijk_g), sqrt(pm*rijk_g), sqrt(qm*rijk_g), & + sqrt(qcwm*rijk_g), sqrt(qrnm*rijk_g) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,5f12.4,6e12.4)') ' ALL', & + sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(wm*rijk_g), & + sqrt(tm*rijk_g), sqrt(pm*rijk_g), sqrt(qm*rijk_g), & + sqrt(qcwm*rijk_g), sqrt(qrnm*rijk_g), sqrt(qcim*rijk_g), & + sqrt(qsnm*rijk_g), sqrt(qgrm*rijk_g) + end select + else + select case ( cloud_cv_options ) + case ( 0 ) + write(unit=stats_unit, fmt='(a,4f12.4,e12.4)') ' ALL', & + sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(tm*rijk_g), & + sqrt(pm*rijk_g), sqrt(qm*rijk_g) + case ( 1 ) + write(unit=stats_unit, fmt='(a,4f12.4,3e12.4)') ' ALL', & + sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(tm*rijk_g), & + sqrt(pm*rijk_g), sqrt(qm*rijk_g), & + sqrt(qcwm*rijk_g), sqrt(qrnm*rijk_g) + case ( 2, 3 ) + write(unit=stats_unit, fmt='(a,4f12.4,6e12.4)') ' ALL', & + sqrt(um*rijk_g), sqrt(vm*rijk_g), sqrt(tm*rijk_g), & + sqrt(pm*rijk_g), sqrt(qm*rijk_g), & + sqrt(qcwm*rijk_g), sqrt(qrnm*rijk_g), sqrt(qcim*rijk_g), & + sqrt(qsnm*rijk_g), sqrt(qgrm*rijk_g) + end select + end if #if (WRF_CHEM == 1) select case ( chem_cv_options ) diff --git a/var/da/da_statistics/da_statistics.f90 b/var/da/da_statistics/da_statistics.f90 index 90f3bca9df..d8aca611b9 100644 --- a/var/da/da_statistics/da_statistics.f90 +++ b/var/da/da_statistics/da_statistics.f90 @@ -11,7 +11,7 @@ module da_statistics #if (WRF_CHEM == 1) chem_cv_options, & #endif - obs_names, ob_vars, filename_len, cloud_cv_options + obs_names, ob_vars, filename_len, cloud_cv_options, use_cv_w use da_define_structures, only : iv_type, maxmin_type, x_type, maxmin_field_type use da_par_util1, only : da_proc_sum_real, da_proc_sum_int, da_proc_sum_ints use da_par_util, only : da_proc_maxmin_combine diff --git a/var/da/da_test/da_check_xtoy_adjoint.inc b/var/da/da_test/da_check_xtoy_adjoint.inc index 6b966820ab..820897820c 100644 --- a/var/da/da_test/da_check_xtoy_adjoint.inc +++ b/var/da/da_test/da_check_xtoy_adjoint.inc @@ -338,6 +338,7 @@ print*,__FILE__,jte,' xa2_v.xa2_v for row= ',jte+1,sum(xa2_v(its:ite, jte+1, kts if (iv%info(airep)%nlocal > 0) call da_check_xtoy_adjoint_airep (iv, y, partial_lhs, pertile_lhs) if (iv%info(pilot)%nlocal > 0) call da_check_xtoy_adjoint_pilot (iv, y, partial_lhs, pertile_lhs) if (iv%info(radar)%nlocal > 0) call da_check_xtoy_adjoint_radar (iv, y, partial_lhs, pertile_lhs) + if (iv%info(lightning)%nlocal> 0) call da_check_xtoy_adjoint_lightning(iv, y, partial_lhs, pertile_lhs) if (iv%info(satem)%nlocal > 0) call da_check_xtoy_adjoint_satem (iv, y, partial_lhs, pertile_lhs) if (iv%info(metar)%nlocal > 0) call da_check_xtoy_adjoint_metar (iv, y, partial_lhs, pertile_lhs) if (iv%info(ships)%nlocal > 0) call da_check_xtoy_adjoint_ships (iv, y, partial_lhs, pertile_lhs) diff --git a/var/da/da_test/da_check_xtoy_adjoint_lightning.inc b/var/da/da_test/da_check_xtoy_adjoint_lightning.inc new file mode 100644 index 0000000000..bba61b3c13 --- /dev/null +++ b/var/da/da_test/da_check_xtoy_adjoint_lightning.inc @@ -0,0 +1,36 @@ +subroutine da_check_xtoy_adjoint_lightning(iv, y, adjtest_lhs, pertile_lhs) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Authors: Z Chen (zchen@fjnu.edu.cn), Jenny Sun (NCAR), X Qie (IAP) + !----------------------------------------------------------------------- + + implicit none + + type (iv_type), intent(in) :: iv ! obs. inc. vector (o-b). + type (y_type) , intent(inout) :: y ! y = h (xa) + real , intent(inout) :: adjtest_lhs, pertile_lhs + + integer :: n, k ! Loop counter. + + if (trace_use_dull) call da_trace_entry("da_check_xtoy_adjoint_lightning") + + do n=iv%info(lightning)%n1, iv%info(lightning)%n2 + if (iv%info(lightning)%proc_domain(1,n)) then + do k=1, iv%info(lightning)%levels(n) + adjtest_lhs = adjtest_lhs + (y%lightning(n)%div(k)/typical_div_rms)**2 + (y%lightning(n)%qv(k)/typical_q_rms)**2 + end do + end if + + do k=1, iv%info(lightning)%levels(n) + pertile_lhs = pertile_lhs + (y%lightning(n)%qv(k)/typical_div_rms)**2 + (y%lightning(n)%qv(k)/typical_q_rms)**2 + y%lightning(n)%div(k) = y%lightning(n)%div(k)/typical_div_rms** 2 + y%lightning(n)%qv(k) = y%lightning(n)%qv(k)/typical_q_rms** 2 + end do + end do + + if (trace_use_dull) call da_trace_exit("da_check_xtoy_adjoint_lightning") + +end subroutine da_check_xtoy_adjoint_lightning + + diff --git a/var/da/da_test/da_get_y_lhs_value.inc b/var/da/da_test/da_get_y_lhs_value.inc index 41f4d014c7..c88b035a3a 100644 --- a/var/da/da_test/da_get_y_lhs_value.inc +++ b/var/da/da_test/da_get_y_lhs_value.inc @@ -26,6 +26,7 @@ subroutine da_get_y_lhs_value (iv, y, partial_lhs, pertile_lhs, adj_ttl_lhs) if (iv%info(airep)%nlocal > 0) call da_check_xtoy_adjoint_airep (iv, y, partial_lhs, pertile_lhs) if (iv%info(pilot)%nlocal > 0) call da_check_xtoy_adjoint_pilot (iv, y, partial_lhs, pertile_lhs) if (iv%info(radar)%nlocal > 0) call da_check_xtoy_adjoint_radar (iv, y, partial_lhs, pertile_lhs) + if (iv%info(lightning)%nlocal > 0) call da_check_xtoy_adjoint_lightning(iv, y, partial_lhs, pertile_lhs) if (iv%info(satem)%nlocal > 0) call da_check_xtoy_adjoint_satem (iv, y, partial_lhs, pertile_lhs) if (iv%info(metar)%nlocal > 0) call da_check_xtoy_adjoint_metar (iv, y, partial_lhs, pertile_lhs) if (iv%info(ships)%nlocal > 0) call da_check_xtoy_adjoint_ships (iv, y, partial_lhs, pertile_lhs) diff --git a/var/da/da_test/da_test.f90 b/var/da/da_test/da_test.f90 index a490164cfb..ba2711317c 100644 --- a/var/da/da_test/da_test.f90 +++ b/var/da/da_test/da_test.f90 @@ -24,7 +24,7 @@ module da_test use da_control, only : trace_use,ierr, trace_use_dull, comm,global,stdout,rootproc, & sfc_assi_options,typical_qrn_rms,typical_qci_rms,typical_qsn_rms,typical_qgr_rms,jcdfi_use, jcdfi_diag, & typical_u_rms,typical_v_rms,typical_w_rms,typical_t_rms, typical_p_rms, typical_rain_rms, & - typical_q_rms,typical_qcw_rms,print_detail_testing,typical_rh_rms, & + typical_q_rms,typical_qcw_rms,print_detail_testing,typical_rh_rms, typical_div_rms,& fg_format, fg_format_wrf_arw_global, fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional, & typical_rf_rms,typical_rv_rms, typical_thickness_rms, typical_tb19v_rms,typical_tb37h_rms, & typical_tb85h_rms,typical_tb37v_rms,typical_tb85v_rms,typical_tb22v_rms, & @@ -35,10 +35,11 @@ module da_test balance_geocyc, var4d, num_fgat_time,cv_options_hum_specific_humidity, & cv_options_hum_relative_humidity, ids, ide, jds, jde, kds, kde, & sound, sonde_sfc, mtgirs, synop, profiler, gpsref, gpspw, polaramv, geoamv, ships, metar, & - satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, tamdar, tamdar_sfc, rain, & + satem, radar, lightning, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, tamdar, tamdar_sfc, rain, & bogus, buoy, qscat, pseudo, radiance, use_radarobs, use_ssmiretrievalobs,use_rainobs, & - use_gpsrefobs, use_ssmt1obs, use_ssmitbobs, use_ssmt2obs, use_gpspwobs, & + use_gpsrefobs, use_ssmt1obs, use_ssmitbobs, use_ssmt2obs, use_gpspwobs, use_lightningobs, & use_gpsztdobs, use_radar_rf, use_radar_rhv, use_rad, crtm_cloud, cloud_cv_options, & + use_lightning_qv, use_lightning_w, use_lightning_div, & ids,ide,jds,jde,kds,kde, ims,ime,jms,jme,kms,kme, fgat_rain_flags, & its,ite,jts,jte,kts,kte, ips,ipe,jps,jpe,kps,kpe, cv_options, cv_size, & cloud_cv_options, cp, gas_constant, test_dm_exact, cv_size_domain, & @@ -132,6 +133,7 @@ module da_test #include "da_check_xtoy_adjoint_ships.inc" #include "da_check_xtoy_adjoint_radar.inc" #include "da_check_xtoy_adjoint_rain.inc" +#include "da_check_xtoy_adjoint_lightning.inc" #include "da_check_xtoy_adjoint_bogus.inc" #include "da_check_xtoy_adjoint_sound.inc" #include "da_check_xtoy_adjoint_sonde_sfc.inc" diff --git a/var/da/da_tools/da_llxy_1d.inc b/var/da/da_tools/da_llxy_1d.inc new file mode 100644 index 0000000000..0752830bc3 --- /dev/null +++ b/var/da/da_tools/da_llxy_1d.inc @@ -0,0 +1,115 @@ +subroutine da_llxy_1d ( infos, locs, outside, outside_all, do_xy, do_outside) + + !----------------------------------------------------------------------- + ! Purpose: TBD + ! Author: JJ Guerrette, MMM/NCAR, Date: 05/23/2018 + ! Modified from da_llxy, including child subroutines + !----------------------------------------------------------------------- + + ! This routine converts (lat, lon) into (x,y) coordinates + + implicit none + + type(info_type), optional, intent(in) :: infos(:) + type(model_loc_type), intent(inout) :: locs(:) + logical , intent(out) :: outside(:) !wrt local domain + logical, optional, intent(out) :: outside_all(:) !wrt all domains + logical, optional, intent(in) :: do_xy, do_outside + logical :: do_xy_, do_outside_ + + if (trace_use) call da_trace_entry("da_llxy_1d") + + outside = .false. + + do_xy_ = .true. + if ( present(do_xy) ) do_xy_ = do_xy + if ( do_xy_ ) then + if (present(infos)) then + locs(:) % x = -1.0 + locs(:) % y = -1.0 + + ! get the (x, y) coordinates + if ( fg_format == fg_format_wrf_arw_regional ) then + call da_llxy_wrf_1d(map_info, infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + else if (fg_format == fg_format_wrf_nmm_regional) then + call da_llxy_rotated_latlon_1d(infos(:)%lat, infos(:)%lon, map_info, locs(:)%x, locs(:)%y) + else if (global) then + call da_llxy_global_1d (infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + else + call da_llxy_default_1d (infos(:)%lat, infos(:)%lon, locs(:)%x, locs(:)%y) + end if + else + message(1)='da_llxy_1d requires infos in order to determine x & y' + call da_error(__FILE__,__LINE__,message(1:1)) + end if + end if + +#ifdef A2C + call da_togrid_1d (locs(:)%x, its-3, ite+3, locs(:)%i, locs(:)%dx, locs(:)%dxm)! + + call da_togrid_1d (locs(:)%y, jts-3, jte+3, locs(:)%j, locs(:)%dy, locs(:)%dym) +#else + call da_togrid_1d (locs(:)%x, its-2, ite+2, locs(:)%i, locs(:)%dx, locs(:)%dxm)! + + call da_togrid_1d (locs(:)%y, jts-2, jte+2, locs(:)%j, locs(:)%dy, locs(:)%dym) +#endif + +! do_outside_ = .true. +! if ( present(do_outside) ) do_outside_ = do_outside +! if ( .not.do_outside_ ) return + + ! refactor to remove this ugly duplication later + if (present(outside_all)) then + outside_all(:) = .false. + ! Do not check for global options + if (.not. global) then + outside_all = outside_all .or. & + (int(locs(:)%x) < ids) .or. (int(locs(:)%x) >= ide) .or. & + (int(locs(:)%y) < jds) .or. (int(locs(:)%y) >= jde) + outside = outside .or. outside_all + if (def_sub_domain) then + outside_all = outside_all .or. & + x_start_sub_domain > locs(:)%x .or. y_start_sub_domain > locs(:)%y .or. & + x_end_sub_domain < locs(:)%x .or. y_end_sub_domain < locs(:)%y + outside = outside .or. outside_all + end if + end if + end if + + if (fg_format == fg_format_kma_global) then + outside = outside .or. & + (locs(:)%j < jts-1) .or. (locs(:)%j > jte) + + where (locs(:)%j == jde) + locs%j = locs%j - 1 + locs%dy = 1.0 + locs%dym = 0.0 + end where + + return + end if + + ! Check for edge of domain: + outside = outside .or. & + (locs(:)%i < ids) .or. (locs(:)%i >= ide) .or. & + (locs(:)%j < jds) .or. (locs(:)%j >= jde) + + ! FIX? hack + outside = outside .or. & +#ifdef A2C + (locs(:)%i < its-2) .or. (locs(:)%i > ite) .or. & + (locs(:)%j < jts-2) .or. (locs(:)%j > jte) +#else + (locs(:)%i < its-1) .or. (locs(:)%i > ite) .or. & + (locs(:)%j < jts-1) .or. (locs(:)%j > jte) +#endif + + if (def_sub_domain) then + outside = outside .or. & + x_start_sub_domain > locs(:)%x .or. y_start_sub_domain > locs(:)%y .or. & + x_end_sub_domain < locs(:)%x .or. y_end_sub_domain < locs(:)%y + end if + + if (trace_use) call da_trace_exit("da_llxy_1d") + +end subroutine da_llxy_1d diff --git a/var/da/da_tools/da_llxy_default_1d.inc b/var/da/da_tools/da_llxy_default_1d.inc new file mode 100644 index 0000000000..011a9d8b74 --- /dev/null +++ b/var/da/da_tools/da_llxy_default_1d.inc @@ -0,0 +1,114 @@ +subroutine da_llxy_default_1d (xlati,xloni,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the (x,y) location (dot) in the mesoscale grids + ! ------- from latitudes and longitudes + ! + ! for global domain co-ordinates + ! + ! input: + ! ----- + ! xlat: latitudes + ! xlon: longitudes + ! + ! output: + ! ----- + ! x: the coordinate in x (i)-direction. + ! y: the coordinate in y (j)-direction. + ! + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: xlati(:), xloni(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: dxlon(:) + real, allocatable :: xlat(:), xlon(:) + real, allocatable :: xx(:), yy(:), cell(:), psx(:), r(:), flp(:) + real :: xc, yc + real :: psi0 + real :: centri, centrj + real :: ratio + real :: bb + real, parameter :: conv = 180.0 / pi + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_default_1d") + + n = size(xlati) + allocate ( dxlon(n), xlat(n), xlon(n), xx(n), yy(n), cell(n), psx(n), r(n), flp(n) ) + + xlon = xloni + xlat = xlati + + where (xlat .lt. -89.95) xlat = -89.95 + where (xlat .gt. +89.95) xlat = +89.95 + + dxlon = xlon - xlonc + where (dxlon > 180) dxlon = dxlon - 360.0 + where (dxlon < -180) dxlon = dxlon + 360.0 + + if (map_projection == 3) then + xc = 0.0 + yc = YCNTR + + cell = cos(xlat/conv)/(1.0+sin(xlat/conv)) + yy = -c2*alog(cell) + xx = c2*dxlon/conv + else + psi0 = (pole - phic)/conv + xc = 0.0 + + ! calculate x,y coords. relative to pole + + flp = cone_factor*dxlon/conv + + psx = (pole - xlat)/conv + + if (map_projection == 2) then + ! Polar stereographics: + bb = 2.0*(cos(psi1/2.0)**2) + yc = -earth_radius*bb*tan(psi0/2.0) + r = -earth_radius*bb*tan(psx/2.0) + else + ! Lambert conformal: + bb = -earth_radius/cone_factor*sin(psi1) + yc = bb*(tan(psi0/2.0)/tan(psi1/2.0))**cone_factor + r = bb*(tan(psx /2.0)/tan(psi1/2.0))**cone_factor + end if + + if (phic < 0.0) then + xx = r*sin(flp) + yy = r*cos(flp) + else + xx = -r*sin(flp) + yy = r*cos(flp) + end if + end if + + ! transform (1,1) to the origin + ! the location of the center in the coarse domain + + centri = real (coarse_ix + 1)/2.0 + centrj = real (coarse_jy + 1)/2.0 + + ! the (x,y) coordinates in the coarse domain + + x = (xx - xc)/coarse_ds + centri + y = (yy - yc)/coarse_ds + centrj + + ratio = coarse_ds / dsm + + ! only add 0.5 so that x/y is relative to first cross points: + + x = (x - start_x) * ratio + 0.5 + y = (y - start_y) * ratio + 0.5 + + deallocate ( dxlon, xlat, xlon, xx, yy, cell, psx, r, flp ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_default_1d") + +end subroutine da_llxy_default_1d + + diff --git a/var/da/da_tools/da_llxy_global_1d.inc b/var/da/da_tools/da_llxy_global_1d.inc new file mode 100644 index 0000000000..9565be5cf5 --- /dev/null +++ b/var/da/da_tools/da_llxy_global_1d.inc @@ -0,0 +1,35 @@ +subroutine da_llxy_global_1d(lat,lon,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the(x,y) location(dot) in the global grids + ! from latitudes and longitudes + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:), lon(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: xlat(:), xlon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_global_1d") + + n = size(lat) + allocate ( xlat(n), xlon(n) ) + + xlat = lat - start_lat + xlon = lon - start_lon + where (xlat < 0.0) xlat = xlat + 180.0 + where (xlon < 0.0) xlon = xlon + 360.0 + + x = start_x + xlon/delt_lon + y = start_y + xlat/delt_lat + if(fg_format == fg_format_wrf_arw_global) & + where (lat.le.start_lat) y = 1.0 + + deallocate ( xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_global_1d") + +end subroutine da_llxy_global_1d diff --git a/var/da/da_tools/da_llxy_kma_global_1d.inc b/var/da/da_tools/da_llxy_kma_global_1d.inc new file mode 100644 index 0000000000..cac3245601 --- /dev/null +++ b/var/da/da_tools/da_llxy_kma_global_1d.inc @@ -0,0 +1,36 @@ +subroutine da_llxy_kma_global_1d(lat,lon,x,y) + + !---------------------------------------------------------------------------- + ! Purpose: calculates the(x,y) location(dot) in the global grids + ! from latitudes and longitudes + !---------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:), lon(:) + real, intent(out) :: x(:), y(:) + + real, allocatable :: xlat(:), xlon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_kma_global_1d") + + n = size(lat) + allocate ( xlat(n), xlon(n) ) + + xlat = lat - start_lat + xlon = lon - start_lon + + where (xlat < 0.0) xlat = xlat + 180.0 + where (xlon < 0.0) xlon = xlon + 360.0 + + x = start_x + xlon/delt_lon + y = start_y + xlat/delt_lat + + deallocate ( xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_kma_global_1d") + +end subroutine da_llxy_kma_global_1d + + diff --git a/var/da/da_tools/da_llxy_latlon_1d.inc b/var/da/da_tools/da_llxy_latlon_1d.inc new file mode 100644 index 0000000000..0b9e869ed9 --- /dev/null +++ b/var/da/da_tools/da_llxy_latlon_1d.inc @@ -0,0 +1,56 @@ +subroutine da_llxy_latlon_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute the x/y location of a lat/lon on a LATLON + ! (cylindrical equidistant) grid. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info), intent(in) :: proj + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + real, allocatable :: deltalat(:) + real, allocatable :: deltalon(:) + real, allocatable :: lon360(:) + real :: latinc + real :: loninc + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_latlon_1d") + + n = size(lat) + allocate ( deltalat(n), deltalon(n), lon360(n) ) + + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360.0 + where (lon < 0) + lon360 = lon + 360.0 + elsewhere + lon360 = lon + end where + + deltalat = lat - proj%lat1 + deltalon = lon360 - proj%lon1 + + !For cylindrical equidistant, dx == dy + loninc = proj%dx*360.0/(2.0*EARTH_RADIUS_M*PI) + latinc = proj%dx*360.0/(2.0*EARTH_RADIUS_M*PI) + + ! Compute x/y + x = deltalon/loninc + y = deltalat/latinc + + x = x + proj%knowni + y = y + proj%knownj + + deallocate ( deltalat, deltalon, lon360 ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_latlon_1d") + +end subroutine da_llxy_latlon_1d + + diff --git a/var/da/da_tools/da_llxy_lc_1d.inc b/var/da/da_tools/da_llxy_lc_1d.inc new file mode 100644 index 0000000000..b56e07b789 --- /dev/null +++ b/var/da/da_tools/da_llxy_lc_1d.inc @@ -0,0 +1,64 @@ +subroutine da_llxy_lc_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: compute the geographical latitude and longitude values + ! to the cartesian x/y on a Lambert Conformal projection. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) ! Latitude (-90->90 deg N) + real, intent(in) :: lon(:) ! Longitude (-180->180 E) + type(proj_info),intent(in) :: proj ! Projection info structure + + real, intent(out) :: x(:) ! Cartesian X coordinate + real, intent(out) :: y(:) ! Cartesian Y coordinate + + real, allocatable :: arg(:) + real, allocatable :: deltalon(:) + real :: tl1r + real, allocatable :: rm(:) + real :: ctl1r + integer :: n + + if (trace_use_dull) call da_trace_entry("da_llxy_lc_1d") + + n = size(lat) + allocate ( arg(n), deltalon(n), rm(n) ) + + ! Compute deltalon between known longitude and standard lon and ensure + ! it is not in the cut zone + deltalon = lon - proj%stdlon + where (deltalon > +180.0) deltalon = deltalon - 360.0 + where (deltalon < -180.0) deltalon = deltalon + 360.0 + + ! Convert truelat1 to radian and compute COS for later use + tl1r = proj%truelat1 * rad_per_deg + ctl1r = COS(tl1r) + + ! Radius to desired point + rm = proj%rebydx * ctl1r/proj%cone * & + (TAN((90.0*proj%hemi-lat)*rad_per_deg/2.0) / & + TAN((90.0*proj%hemi-proj%truelat1)*rad_per_deg/2.0))**proj%cone + + arg = proj%cone*(deltalon*rad_per_deg) + x = proj%polei + proj%hemi * rm * Sin(arg) + y = proj%polej - rm * COS(arg) + + ! Finally, if we are in the southern hemisphere, flip the i/j + ! values to a coordinate system where (1,1) is the SW corner + ! (what we assume) which is different than the original NCEP + ! algorithms which used the NE corner as the origin in the + ! southern hemisphere (left-hand vs. right-hand coordinate?) + if (proj%hemi == -1.0) then + x = 2.0 - x + y = 2.0 - y + end if + + deallocate ( arg, deltalon, rm ) + + if (trace_use_dull) call da_trace_exit("da_llxy_lc_1d") + +end subroutine da_llxy_lc_1d + + diff --git a/var/da/da_tools/da_llxy_merc_1d.inc b/var/da/da_tools/da_llxy_merc_1d.inc new file mode 100644 index 0000000000..ef39acf721 --- /dev/null +++ b/var/da/da_tools/da_llxy_merc_1d.inc @@ -0,0 +1,35 @@ +subroutine da_llxy_merc_1d(lat, lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute x,y coordinate from lat lon for mercator projection + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info),intent(in) :: proj + real,intent(out) :: x(:) + real,intent(out) :: y(:) + real, allocatable :: deltalon(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_merc_1d") + + n = size(lat) + allocate ( deltalon(n) ) + + deltalon = lon - proj%lon1 + where (deltalon < -180.0) deltalon = deltalon + 360.0 + where (deltalon > 180.0) deltalon = deltalon - 360.0 + x = 1.0 + (deltalon/(proj%dlon*deg_per_rad)) + y = 1.0 + (ALOG(TAN(0.5*((lat + 90.0) * rad_per_deg)))) / & + proj%dlon - proj%rsw + + deallocate ( deltalon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_merc_1d") + +end subroutine da_llxy_merc_1d + + diff --git a/var/da/da_tools/da_llxy_ps_1d.inc b/var/da/da_tools/da_llxy_ps_1d.inc new file mode 100644 index 0000000000..3c39cfb9fb --- /dev/null +++ b/var/da/da_tools/da_llxy_ps_1d.inc @@ -0,0 +1,50 @@ +subroutine da_llxy_ps_1d(lat,lon,proj,x,y) + + !----------------------------------------------------------------------- + ! Purpose: Given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard polar-stereographic projection information via the + ! public proj structure, this routine returns the x/y indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info),intent(in) :: proj + + real, intent(out) :: x(:) !(x-index) + real, intent(out) :: y(:) !(y-index) + + real :: reflon + real :: scale_top + real, allocatable :: ala(:) + real, allocatable :: alo(:) + real, allocatable :: rm(:) + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_ps_1d") + + reflon = proj%stdlon + 90.0 + + ! Compute numerator term of map scale factor + + scale_top = 1.0 + proj%hemi * Sin(proj%truelat1 * rad_per_deg) + + ! Find radius to desired point + n = size(lat) + allocate ( ala(n), alo(n), rm(n) ) + + ala = lat * rad_per_deg + rm = proj%rebydx * COS(ala) * scale_top/(1.0 + proj%hemi *Sin(ala)) + alo = (lon - reflon) * rad_per_deg + x = proj%polei + rm * COS(alo) + y = proj%polej + proj%hemi * rm * Sin(alo) + + deallocate ( ala, alo, rm ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_ps_1d") + +end subroutine da_llxy_ps_1d + + diff --git a/var/da/da_tools/da_llxy_rotated_latlon_1d.inc b/var/da/da_tools/da_llxy_rotated_latlon_1d.inc new file mode 100644 index 0000000000..bc802c4da8 --- /dev/null +++ b/var/da/da_tools/da_llxy_rotated_latlon_1d.inc @@ -0,0 +1,60 @@ +subroutine da_llxy_rotated_latlon_1d(lat,lon, proj, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Compute the x/y location of a lat/lon on a rotated LATLON grid. + ! Author : Syed RH Rizvi, MMM/NCAR + ! 06/01/2008 + !--------------------------------------------------------------------------- + + implicit none + + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + type(proj_info), intent(in) :: proj + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + real, allocatable :: rot_lat(:), rot_lon(:), deltalat(:), deltalon(:), lon360(:) + real, allocatable :: xlat(:), xlon(:) + real :: cen_lat, cen_lon, latinc, loninc + integer :: n + + if (trace_use_frequent) call da_trace_entry("da_llxy_rotated_latlon_1d") + + n = size(lat) + allocate ( rot_lat(n), rot_lon(n), deltalat(n), deltalon(n), lon360(n), xlat(n), xlon(n) ) + + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360.0 + where (lon < 0) + lon360 = lon + 360.0 + elsewhere + lon360 = lon + end where + + xlat = deg_to_rad*lat + xlon = deg_to_rad*lon360 + cen_lat = deg_to_rad*proj%lat1 + cen_lon = deg_to_rad*proj%lon1 + if (cen_lon < 0.) cen_lon = cen_lon + 360. + + latinc = proj%latinc + loninc = proj%loninc + + rot_lon = rad_to_deg*atan( cos(xlat) * sin(xlon-cen_lon)/ & + (cos(cen_lat)*cos(xlat)*cos(xlon-cen_lon) + sin(cen_lat)*sin(xlat))) + rot_lat = rad_to_deg*asin( cos(cen_lat)*sin(xlat) - sin(cen_lat)*cos(xlat)*cos(xlon-cen_lon)) + + + deltalat = rot_lat + deltalon = rot_lon + + ! Compute x/y + x = proj%knowni + deltalon/loninc + 1.0 + y = proj%knownj + deltalat/latinc + 1.0 + + deallocate ( rot_lat, rot_lon, deltalat, deltalon, lon360, xlat, xlon ) + + if (trace_use_frequent) call da_trace_exit("da_llxy_rotated_latlon_1d") + +end subroutine da_llxy_rotated_latlon_1d diff --git a/var/da/da_tools/da_llxy_wrf_1d.inc b/var/da/da_tools/da_llxy_wrf_1d.inc new file mode 100644 index 0000000000..4a46d9b34c --- /dev/null +++ b/var/da/da_tools/da_llxy_wrf_1d.inc @@ -0,0 +1,51 @@ +subroutine da_llxy_wrf_1d(proj, lat, lon, x, y) + + !----------------------------------------------------------------------- + ! Purpose: Converts input lat/lon values to the cartesian (x, y) value + ! for the given projection. + !----------------------------------------------------------------------- + + implicit none + + type(proj_info), intent(in) :: proj + real, intent(in) :: lat(:) + real, intent(in) :: lon(:) + real, intent(out) :: x(:) + real, intent(out) :: y(:) + + if (trace_use_frequent) call da_trace_entry("da_llxy_wrf_1d") + + if (.NOT.proj%init) then + call da_error(__FILE__,__LINE__, & + (/"You have not called map_set for this projection!"/)) + end if + + select case(proj%code) + + case(PROJ_LATLON) + call da_llxy_latlon_1d(lat,lon,proj,x,y) + + case(PROJ_MERC) + call da_llxy_merc_1d(lat,lon,proj,x,y) + x = x + proj%knowni - 1.0 + y = y + proj%knownj - 1.0 + + case(PROJ_PS) + call da_llxy_ps_1d(lat,lon,proj,x,y) + + case(PROJ_LC) + call da_llxy_lc_1d(lat,lon,proj,x,y) + x = x + proj%knowni - 1.0 + y = y + proj%knownj - 1.0 + + case default + write(unit=message(1),fmt='(A,I2)') & + 'Unrecognized map projection code: ', proj%code + call da_error(__FILE__,__LINE__,message(1:1)) + end select + + if (trace_use_frequent) call da_trace_exit("da_llxy_wrf_1d") + +end subroutine da_llxy_wrf_1d + + diff --git a/var/da/da_tools/da_togrid_1d.inc b/var/da/da_tools/da_togrid_1d.inc new file mode 100644 index 0000000000..262a446e7f --- /dev/null +++ b/var/da/da_tools/da_togrid_1d.inc @@ -0,0 +1,44 @@ +subroutine da_togrid_1d (x, ib, ie, i, dx, dxm) + + !----------------------------------------------------------------------- + ! Purpose: Transfer obs. x to grid i and calculate its + ! distance to grid i and i+1 + !----------------------------------------------------------------------- + + implicit none + + real, intent(in) :: x(:) + integer, intent(in) :: ib, ie + real, intent(out) :: dx(:), dxm(:) + integer, intent(out) :: i(:) + + if (trace_use) call da_trace_entry("da_togrid_1d") + +! where (x(:) > 0.0) +! i = int (x) +! +! where(i(:) < ib) i = ib +! where(i(:) >= ie) i = ie-1 +! +! dx = x - real(i) +! dxm = 1.0 - dx +! elsewhere +! i = 0 +! dx = 0.0 +! dxm = 0.0 +! end where + + i = int (x) + where (i(:) < ib) + i = ib + elsewhere (i(:) >= ie) + i = ie - 1 + end where + dx = x - real(i) + dxm = 1.0 - dx + + if (trace_use) call da_trace_exit("da_togrid_1d") + +end subroutine da_togrid_1d + + diff --git a/var/da/da_tools/da_tools.f90 b/var/da/da_tools/da_tools.f90 index ced8aa918b..fa5247d1c1 100644 --- a/var/da/da_tools/da_tools.f90 +++ b/var/da/da_tools/da_tools.f90 @@ -65,6 +65,18 @@ module da_tools #include "da_llxy_ps_new.inc" #include "da_llxy_wrf.inc" #include "da_llxy_wrf_new.inc" + +#include "da_llxy_1d.inc" +#include "da_llxy_default_1d.inc" +#include "da_llxy_kma_global_1d.inc" +#include "da_llxy_global_1d.inc" +#include "da_llxy_rotated_latlon_1d.inc" +#include "da_llxy_latlon_1d.inc" +#include "da_llxy_lc_1d.inc" +#include "da_llxy_merc_1d.inc" +#include "da_llxy_ps_1d.inc" +#include "da_llxy_wrf_1d.inc" + #include "da_xyll.inc" #include "da_xyll_default.inc" #include "da_xyll_latlon.inc" @@ -98,6 +110,7 @@ module da_tools #include "da_smooth_anl.inc" #include "da_togrid_new.inc" #include "da_togrid.inc" +#include "da_togrid_1d.inc" #include "da_unifva.inc" #include "da_buddy_qc.inc" diff --git a/var/external/bufr/bufrlib.h b/var/external/bufr/bufrlib.h index d19fc65a28..7473c1b7bf 100644 --- a/var/external/bufr/bufrlib.h +++ b/var/external/bufr/bufrlib.h @@ -94,6 +94,7 @@ void cwbmg( char *, f77int *, f77int * ); void elemdx( char *, f77int *, f77int ); void gets1loc( char *, f77int *, f77int *, f77int *, f77int *, f77int ); f77int ichkstr ( char *, char *, f77int *, f77int, f77int ); +f77int icvidx( f77int *, f77int *, f77int * ); f77int ifxy( char *, f77int ); f77int igetntbi( f77int *, char *, f77int ); f77int igettdi( f77int * ); @@ -108,6 +109,7 @@ void numtbd( f77int *, f77int *, char *, char *, f77int *, f77int, f77int ); void pktdd( f77int *, f77int *, f77int *, f77int * ); f77int rbytes( char *, f77int *, f77int, f77int ); void restd( f77int *, f77int *, f77int *, f77int * ); +void stntbi( f77int *, f77int *, char *, char *, char * ); void strnum( char *, f77int *, f77int ); void stseq( f77int *, f77int *, f77int *, char *, char *, f77int *, f77int * ); void uptdd( f77int *, f77int *, f77int *, f77int * ); diff --git a/var/external/bufr/preproc.sh b/var/external/bufr/preproc.sh index 42564243ad..bc5ac7d587 100755 --- a/var/external/bufr/preproc.sh +++ b/var/external/bufr/preproc.sh @@ -15,14 +15,14 @@ cat > endiantest.c << ENDIANTEST } \ printf("\n"); -void fill(p, size) char *p; int size; { +void fill(char *p, int size) { char *ab= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; int i; for (i=0; i Bias predictor statistics: Mean & Std & Nbgerr + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 + 10000 10000 10000 10000 10000 10000 10000 10000 + -----> Chanl_id Chanl_nb Pred_use(-1/0/1) Param + 1 1 0 0 0 0 0 -1 -1 -1 2.100 0.000 0.000 0.000 0.000 + 2 2 0 0 0 0 0 -1 -1 -1 0.299 0.000 -0.001 -0.006 0.009 + 3 3 0 0 0 0 0 -1 -1 -1 0.516 0.001 -0.005 0.000 0.019 + 4 4 0 0 0 0 0 -1 -1 -1 -0.095 -0.005 0.001 -0.002 0.024 + 5 5 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 + 6 6 0 0 0 0 0 -1 -1 -1 0.000 0.000 0.000 0.000 0.000 + 7 7 0 0 0 0 0 -1 -1 -1 -0.800 0.000 0.000 0.000 0.000 + 8 8 0 0 0 0 0 -1 -1 -1 -0.600 0.000 0.000 0.000 0.000 + 9 9 0 0 0 0 0 -1 -1 -1 -1.000 0.000 0.000 0.000 0.000 + 10 10 0 0 0 0 0 -1 -1 -1 -2.000 0.000 0.000 0.000 0.000 ------------------------------------------------ Platform_id Sat_id Sensor_id Nchanl Npredmax ------------------------------------------------ diff --git a/var/run/hydro_mean.dat b/var/run/hydro_mean.dat new file mode 100644 index 0000000000..8eb4898a78 --- /dev/null +++ b/var/run/hydro_mean.dat @@ -0,0 +1,281 @@ +z_index: h_index: ===Rainwater=== ===Wet snow=== ===Dry snow=== ===Graupel=== + 1 1 1.110364621 0.000000000 0.000000000 0.000000000 + 1 2 1.191557061 0.000000000 0.000000000 0.000000000 + 1 3 1.161192223 0.000000422 0.000000000 0.000000012 + 1 4 1.184153769 0.000000491 0.000000000 0.000000861 + 1 5 1.215461736 0.000001245 0.000000000 0.000032498 + 1 6 1.249331021 0.000003465 0.000000000 0.000434329 + 1 7 1.188016575 0.004044376 0.000000000 0.006002718 + 1 8 0.658994592 0.258770821 0.000000000 0.023394588 + 1 9 0.076126130 0.493034557 0.041413365 0.089647445 + 1 10 0.018769813 0.001490633 0.602470884 0.246930429 + 1 11 0.012606547 0.000000000 0.682771950 0.218481389 + 1 12 0.006803642 0.000000000 0.774319410 0.166622734 + 1 13 0.002194630 0.000000000 0.973009700 0.103653619 + 1 14 0.000539458 0.000000000 1.057978759 0.062300466 + 1 15 0.000082431 0.000000000 1.124476300 0.031163022 + 1 16 0.000006093 0.000000000 1.181231493 0.016328655 + 1 17 0.000000633 0.000000000 1.186018000 0.008443903 + 1 18 0.000000026 0.000000000 1.184349250 0.005027429 + 1 19 0.000000000 0.000000000 1.204235782 0.002984170 + 1 20 0.000000000 0.000000000 1.247787931 0.001683112 + 1 21 0.000000000 0.000000000 1.182761010 0.001269201 + 1 22 0.000000000 0.000000000 1.147730129 0.001016334 + 1 23 0.000000000 0.000000000 1.081208081 0.001700866 + 1 24 0.000000000 0.000000000 1.058804569 0.002569211 + 1 25 0.000000000 0.000000000 1.069680539 0.004297983 + 1 26 0.000000000 0.000000000 1.105473007 0.007288858 + 1 27 0.000000000 0.000000000 1.123479694 0.012151141 + 1 28 0.000000000 0.000000000 1.077309190 0.021671793 + 1 29 0.000000000 0.000000000 1.052393202 0.048595214 + 1 30 0.000000000 0.000000000 1.075984323 0.070006682 + 1 31 0.000000000 0.000000000 0.931566007 0.133371018 + 1 32 0.000000000 0.000000000 0.747305077 0.325729422 + 1 33 0.000000000 0.000000000 0.644699148 0.487301524 + 1 34 0.000000000 0.000000000 0.450743857 0.445289492 + 1 35 0.000000000 0.000000000 0.000000000 0.000000000 + 1 36 0.000000000 0.000000000 0.000000000 0.000000000 + 1 37 0.000000000 0.000000000 0.000000000 0.000000000 + 1 38 0.000000000 0.000000000 0.000000000 0.000000000 + 1 39 0.000000000 0.000000000 0.000000000 0.000000000 + 1 40 0.000000000 0.000000000 0.000000000 0.000000000 + 2 1 11.485129451 0.000000000 0.000000000 0.000003007 + 2 2 11.396482615 0.000000000 0.000000000 0.000002900 + 2 3 11.185311921 0.000000000 0.000000000 0.000009683 + 2 4 11.235017166 0.000000000 0.000000000 0.000194856 + 2 5 11.906867881 0.000000000 0.000000000 0.002666470 + 2 6 11.398847925 0.000004541 0.000000000 0.022052947 + 2 7 11.083775847 0.033225508 0.000000000 0.146095935 + 2 8 5.601100129 3.143440880 0.000000000 0.453400773 + 2 9 0.385149278 4.427440268 0.842305357 1.350949073 + 2 10 0.074431311 0.005787899 7.263531568 2.738786067 + 2 11 0.061621934 0.000000000 8.502123869 2.235457196 + 2 12 0.025156071 0.000000000 9.505179215 1.626797976 + 2 13 0.010992198 0.000000000 10.101719191 1.078340551 + 2 14 0.003244363 0.000000000 10.231194394 0.741196853 + 2 15 0.000662645 0.000000000 10.552275893 0.472961157 + 2 16 0.000098238 0.000000000 11.064867118 0.251980352 + 2 17 0.000012384 0.000000000 11.666488175 0.141560635 + 2 18 0.000000634 0.000000000 12.120665829 0.083122906 + 2 19 0.000000010 0.000000000 12.226585112 0.057658141 + 2 20 0.000000001 0.000000000 11.835602963 0.052477660 + 2 21 0.000000000 0.000000000 10.691880050 0.053115267 + 2 22 0.000000000 0.000000000 10.217975933 0.045675562 + 2 23 0.000000000 0.000000000 10.638193393 0.080667913 + 2 24 0.000000000 0.000000000 10.270044193 0.097538724 + 2 25 0.000000000 0.000000000 10.790678433 0.129937144 + 2 26 0.000000000 0.000000000 10.138613304 0.195182422 + 2 27 0.000000000 0.000000000 10.388859246 0.390972109 + 2 28 0.000000000 0.000000000 10.026214473 0.655879823 + 2 29 0.000000000 0.000000000 10.448562136 1.164410662 + 2 30 0.000000000 0.000000000 9.255934098 1.542579014 + 2 31 0.000000000 0.000000000 6.739038416 3.212334382 + 2 32 0.000000000 0.000000000 4.253683315 5.936382508 + 2 33 0.000000000 0.000000000 2.620775698 6.022844513 + 2 34 0.000000000 0.000000000 1.516023585 4.217000919 + 2 35 0.000000000 0.000000000 0.000000000 0.000000000 + 2 36 0.000000000 0.000000000 0.000000000 0.000000000 + 2 37 0.000000000 0.000000000 0.000000000 0.000000000 + 2 38 0.000000000 0.000000000 0.000000000 0.000000000 + 2 39 0.000000000 0.000000000 0.000000000 0.000000000 + 2 40 0.000000000 0.000000000 0.000000000 0.000000000 + 3 1 109.932737059 0.000000000 0.000000000 0.007300182 + 3 2 122.092308392 0.000000000 0.000000000 0.004750457 + 3 3 108.299617642 0.000000000 0.000000000 0.012055900 + 3 4 101.792502801 0.000000000 0.000000000 0.030280001 + 3 5 100.160428959 0.000000000 0.000000000 0.116610347 + 3 6 103.856724007 0.000012841 0.000000000 0.481703396 + 3 7 98.090295840 0.378111314 0.000000000 3.373334736 + 3 8 37.170010844 43.881337887 0.000000000 7.231537025 + 3 9 1.986512900 59.245030215 3.788333765 14.542833224 + 3 10 0.257588682 0.079139965 59.148690698 33.963358072 + 3 11 0.142639374 0.000000000 74.379298950 24.212025312 + 3 12 0.062449161 0.000000000 85.695554670 16.296630658 + 3 13 0.044433424 0.000000000 90.834574411 11.697786901 + 3 14 0.013513088 0.000000000 100.614643042 7.783517598 + 3 15 0.002632258 0.000000000 105.313449943 4.882578074 + 3 16 0.000608011 0.000000000 104.875563707 3.515404060 + 3 17 0.000127344 0.000000000 100.332384837 2.697175298 + 3 18 0.000011229 0.000000000 94.444999278 2.283756425 + 3 19 0.000000849 0.000000000 91.343376648 2.281776948 + 3 20 0.000000114 0.000000000 90.858339122 2.950994033 + 3 21 0.000000018 0.000000000 95.499549882 3.737628459 + 3 22 0.000000000 0.000000000 95.559053301 3.206116511 + 3 23 0.000000000 0.000000000 93.723659784 4.629463735 + 3 24 0.000000000 0.000000000 93.300850497 5.858860033 + 3 25 0.000000000 0.000000000 95.178401387 7.444054514 + 3 26 0.000000000 0.000000000 97.461499396 8.145390824 + 3 27 0.000000000 0.000000000 87.133350811 11.663855996 + 3 28 0.000000000 0.000000000 80.834832519 13.460996914 + 3 29 0.000000000 0.000000000 84.814338244 15.834966383 + 3 30 0.000000000 0.000000000 69.391744019 33.927804794 + 3 31 0.000000000 0.000000000 30.083735714 58.070284810 + 3 32 0.000000000 0.000000000 12.257326573 55.287309841 + 3 33 0.000000000 0.000000000 0.000000000 0.000000000 + 3 34 0.000000000 0.000000000 0.000000000 0.000000000 + 3 35 0.000000000 0.000000000 0.000000000 0.000000000 + 3 36 0.000000000 0.000000000 0.000000000 0.000000000 + 3 37 0.000000000 0.000000000 0.000000000 0.000000000 + 3 38 0.000000000 0.000000000 0.000000000 0.000000000 + 3 39 0.000000000 0.000000000 0.000000000 0.000000000 + 3 40 0.000000000 0.000000000 0.000000000 0.000000000 + 4 1 582.593809462 0.000000000 0.000000000 0.275695684 + 4 2 862.795555369 0.000000000 0.000000000 0.445421273 + 4 3 891.383213768 0.000000000 0.000000000 1.101761842 + 4 4 847.098276169 0.000000000 0.000000000 3.643758990 + 4 5 788.052922707 0.000000001 0.000000000 9.016362689 + 4 6 775.932257572 0.000351128 0.000000000 27.869731729 + 4 7 684.552482610 6.937820624 0.000000000 96.504729633 + 4 8 165.141711916 602.918935837 0.000000000 77.354169482 + 4 9 11.110636789 841.094650399 6.179351624 73.141773422 + 4 10 2.592036028 2.737345087 258.937787057 546.620437475 + 4 11 0.844255872 0.000000000 393.879602971 428.287945544 + 4 12 0.317489641 0.000000000 499.466047843 305.905580600 + 4 13 0.191266101 0.000000000 549.092489790 245.526019251 + 4 14 0.082059535 0.000000000 610.522719671 187.512000878 + 4 15 0.053360187 0.000000000 631.848753741 158.688350577 + 4 16 0.034991483 0.000000000 658.186633724 154.982817570 + 4 17 0.017887056 0.000000000 682.103320599 165.294918242 + 4 18 0.003462044 0.000000000 686.448995011 171.743749840 + 4 19 0.000334653 0.000000000 671.701302583 174.346198287 + 4 20 0.000028286 0.000000000 660.096023344 185.927444415 + 4 21 0.000004650 0.000000000 701.677255663 200.345430022 + 4 22 0.000000131 0.000000000 721.448748841 200.200056715 + 4 23 0.000000000 0.000000000 692.662575998 173.064245844 + 4 24 0.000000000 0.000000000 737.784120807 182.548421609 + 4 25 0.000000000 0.000000000 770.023711050 158.227222727 + 4 26 0.000000000 0.000000000 793.757906639 155.100836077 + 4 27 0.000000000 0.000000000 741.519916987 201.064163937 + 4 28 0.000000000 0.000000000 672.930450614 237.650181985 + 4 29 0.000000000 0.000000000 443.019863425 306.677426487 + 4 30 0.000000000 0.000000000 190.427776503 401.203266619 + 4 31 0.000000000 0.000000000 73.085580942 376.938006133 + 4 32 0.000000000 0.000000000 0.000000000 0.000000000 + 4 33 0.000000000 0.000000000 0.000000000 0.000000000 + 4 34 0.000000000 0.000000000 0.000000000 0.000000000 + 4 35 0.000000000 0.000000000 0.000000000 0.000000000 + 4 36 0.000000000 0.000000000 0.000000000 0.000000000 + 4 37 0.000000000 0.000000000 0.000000000 0.000000000 + 4 38 0.000000000 0.000000000 0.000000000 0.000000000 + 4 39 0.000000000 0.000000000 0.000000000 0.000000000 + 4 40 0.000000000 0.000000000 0.000000000 0.000000000 + 5 1 0.000000000 0.000000000 0.000000000 0.000000000 + 5 2 5578.212864738 0.000000000 0.000000000 5.008952656 + 5 3 5372.103162093 0.000000000 0.000000000 15.041257061 + 5 4 5409.303983283 0.000000000 0.000000000 53.293005337 + 5 5 5618.973616023 0.000000000 0.000000000 143.608558988 + 5 6 4879.392758682 0.000059368 0.000000000 577.809533511 + 5 7 4349.351164642 2.596033085 0.000000000 1801.203238199 + 5 8 854.397245908 4577.243654527 0.000000000 921.156400737 + 5 9 75.919974478 9679.349939645 0.367917266 405.301875485 + 5 10 30.335561303 461.116686680 412.412251661 5431.263523222 + 5 11 21.568149623 0.000000000 943.750748633 7496.776413933 + 5 12 6.205921446 0.000000000 1263.739261662 7039.395051868 + 5 13 3.792888765 0.000000000 1407.049350326 6724.745434684 + 5 14 3.038712738 0.000000000 1790.658381642 5919.476026227 + 5 15 2.853361147 0.000000000 2068.818886995 5413.289648478 + 5 16 2.403568418 0.000000000 2216.382731337 5005.192492141 + 5 17 1.565186269 0.000000000 2320.988829920 4802.670353956 + 5 18 0.376286682 0.000000000 2400.454833272 4344.940778358 + 5 19 0.036770184 0.000000000 2588.226752918 3615.891464519 + 5 20 0.002523353 0.000000000 2787.011057487 3022.057443383 + 5 21 0.000221743 0.000000000 2508.866032337 3016.475286259 + 5 22 0.000017548 0.000000000 2586.553484818 3026.145356612 + 5 23 0.000000002 0.000000000 3070.760438617 1818.735698531 + 5 24 0.000000000 0.000000000 2372.313361303 2504.319989388 + 5 25 0.000000000 0.000000000 2670.223119035 1809.783614435 + 5 26 0.000000000 0.000000000 2097.739600125 2207.333859109 + 5 27 0.000000000 0.000000000 1778.791933499 2413.184645816 + 5 28 0.000000000 0.000000000 1151.672803739 2910.940558316 + 5 29 0.000000000 0.000000000 712.314792483 2915.130593453 + 5 30 0.000000000 0.000000000 0.000000000 0.000000000 + 5 31 0.000000000 0.000000000 0.000000000 0.000000000 + 5 32 0.000000000 0.000000000 0.000000000 0.000000000 + 5 33 0.000000000 0.000000000 0.000000000 0.000000000 + 5 34 0.000000000 0.000000000 0.000000000 0.000000000 + 5 35 0.000000000 0.000000000 0.000000000 0.000000000 + 5 36 0.000000000 0.000000000 0.000000000 0.000000000 + 5 37 0.000000000 0.000000000 0.000000000 0.000000000 + 5 38 0.000000000 0.000000000 0.000000000 0.000000000 + 5 39 0.000000000 0.000000000 0.000000000 0.000000000 + 5 40 0.000000000 0.000000000 0.000000000 0.000000000 + 6 1 0.000000000 0.000000000 0.000000000 0.000000000 + 6 2 0.000000000 0.000000000 0.000000000 0.000000000 + 6 3 0.000000000 0.000000000 0.000000000 0.000000000 + 6 4 0.000000000 0.000000000 0.000000000 0.000000000 + 6 5 0.000000000 0.000000000 0.000000000 0.000000000 + 6 6 0.000000000 0.000000000 0.000000000 0.000000000 + 6 7 0.000000000 0.000000000 0.000000000 0.000000000 + 6 8 585.441438425 54783.345060723 0.000000000 435.573114800 + 6 9 274.433475945 58482.456351137 0.000000000 1681.712939361 + 6 10 336.916776730 72160.296616061 7.104634902 7034.338489053 + 6 11 525.273471409 0.000000000 471.183532054 50751.765613477 + 6 12 100.010286359 0.000000000 617.046488536 51050.961892201 + 6 13 34.699959319 0.000000000 870.849970379 46579.609004041 + 6 14 32.881914560 0.000000000 1047.803060470 42096.679451858 + 6 15 34.787300955 0.000000000 998.529025322 39468.443642318 + 6 16 34.937999378 0.000000000 912.658347862 37910.400787624 + 6 17 29.476320004 0.000000000 946.200593796 37480.851970615 + 6 18 13.600879797 0.000000000 830.800168234 36555.339790068 + 6 19 0.000000000 0.000000000 0.000000000 0.000000000 + 6 20 0.000000000 0.000000000 0.000000000 0.000000000 + 6 21 0.000000000 0.000000000 0.000000000 0.000000000 + 6 22 0.000000000 0.000000000 0.000000000 0.000000000 + 6 23 0.000000000 0.000000000 0.000000000 0.000000000 + 6 24 0.000000000 0.000000000 0.000000000 0.000000000 + 6 25 0.000000000 0.000000000 0.000000000 0.000000000 + 6 26 0.000000000 0.000000000 0.000000000 0.000000000 + 6 27 0.000000000 0.000000000 0.000000000 0.000000000 + 6 28 0.000000000 0.000000000 0.000000000 0.000000000 + 6 29 0.000000000 0.000000000 0.000000000 0.000000000 + 6 30 0.000000000 0.000000000 0.000000000 0.000000000 + 6 31 0.000000000 0.000000000 0.000000000 0.000000000 + 6 32 0.000000000 0.000000000 0.000000000 0.000000000 + 6 33 0.000000000 0.000000000 0.000000000 0.000000000 + 6 34 0.000000000 0.000000000 0.000000000 0.000000000 + 6 35 0.000000000 0.000000000 0.000000000 0.000000000 + 6 36 0.000000000 0.000000000 0.000000000 0.000000000 + 6 37 0.000000000 0.000000000 0.000000000 0.000000000 + 6 38 0.000000000 0.000000000 0.000000000 0.000000000 + 6 39 0.000000000 0.000000000 0.000000000 0.000000000 + 6 40 0.000000000 0.000000000 0.000000000 0.000000000 + 7 1 0.000000000 0.000000000 0.000000000 0.000000000 + 7 2 0.000000000 0.000000000 0.000000000 0.000000000 + 7 3 0.000000000 0.000000000 0.000000000 0.000000000 + 7 4 0.000000000 0.000000000 0.000000000 0.000000000 + 7 5 0.000000000 0.000000000 0.000000000 0.000000000 + 7 6 0.000000000 0.000000000 0.000000000 0.000000000 + 7 7 0.000000000 0.000000000 0.000000000 0.000000000 + 7 8 0.000000000 0.000000000 0.000000000 0.000000000 + 7 9 2.583919647 368559.529798930 0.000000000 293.474202984 + 7 10 75.463310355 380388.338450024 0.000000000 3151.421917646 + 7 11 0.000000000 0.000000000 0.000000000 0.000000000 + 7 12 0.000000000 0.000000000 0.000000000 0.000000000 + 7 13 0.000000000 0.000000000 0.000000000 0.000000000 + 7 14 0.000000000 0.000000000 0.000000000 0.000000000 + 7 15 0.000000000 0.000000000 0.000000000 0.000000000 + 7 16 0.000000000 0.000000000 0.000000000 0.000000000 + 7 17 0.000000000 0.000000000 0.000000000 0.000000000 + 7 18 0.000000000 0.000000000 0.000000000 0.000000000 + 7 19 0.000000000 0.000000000 0.000000000 0.000000000 + 7 20 0.000000000 0.000000000 0.000000000 0.000000000 + 7 21 0.000000000 0.000000000 0.000000000 0.000000000 + 7 22 0.000000000 0.000000000 0.000000000 0.000000000 + 7 23 0.000000000 0.000000000 0.000000000 0.000000000 + 7 24 0.000000000 0.000000000 0.000000000 0.000000000 + 7 25 0.000000000 0.000000000 0.000000000 0.000000000 + 7 26 0.000000000 0.000000000 0.000000000 0.000000000 + 7 27 0.000000000 0.000000000 0.000000000 0.000000000 + 7 28 0.000000000 0.000000000 0.000000000 0.000000000 + 7 29 0.000000000 0.000000000 0.000000000 0.000000000 + 7 30 0.000000000 0.000000000 0.000000000 0.000000000 + 7 31 0.000000000 0.000000000 0.000000000 0.000000000 + 7 32 0.000000000 0.000000000 0.000000000 0.000000000 + 7 33 0.000000000 0.000000000 0.000000000 0.000000000 + 7 34 0.000000000 0.000000000 0.000000000 0.000000000 + 7 35 0.000000000 0.000000000 0.000000000 0.000000000 + 7 36 0.000000000 0.000000000 0.000000000 0.000000000 + 7 37 0.000000000 0.000000000 0.000000000 0.000000000 + 7 38 0.000000000 0.000000000 0.000000000 0.000000000 + 7 39 0.000000000 0.000000000 0.000000000 0.000000000 + 7 40 0.000000000 0.000000000 0.000000000 0.000000000 diff --git a/var/run/radiance_info/goes-16-abi.info b/var/run/radiance_info/goes-16-abi.info new file mode 100644 index 0000000000..7c3cd410c8 --- /dev/null +++ b/var/run/radiance_info/goes-16-abi.info @@ -0,0 +1,11 @@ +sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 7 1 -1 0 2.7200000000E+00 0.0000000000E+00 25.00000 12.00000 + 1023 8 1 1 0 1.7900000000E+00 0.0000000000E+00 8.60000 18.00000 + 1023 9 1 1 0 1.9200000000E+00 0.0000000000E+00 12.00000 26.00000 + 1023 10 1 1 0 1.7400000000E+00 0.0000000000E+00 16.90000 23.00000 + 1023 11 1 -1 0 5.0000000000E+00 0.0000000000E+00 27.00000 18.00000 + 1023 12 1 -1 0 2.7900000000E+00 0.0000000000E+00 15.00000 10.00000 + 1023 13 1 -1 0 3.0800000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 14 1 -1 0 3.0600000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 15 1 -1 0 2.8200000000E+00 0.0000000000E+00 28.00000 20.00000 + 1023 16 1 -1 0 1.7400000000E+00 0.0000000000E+00 20.00000 12.00000 diff --git a/var/run/radiance_info/goes-17-abi.info b/var/run/radiance_info/goes-17-abi.info new file mode 100644 index 0000000000..db8322f635 --- /dev/null +++ b/var/run/radiance_info/goes-17-abi.info @@ -0,0 +1,11 @@ +sensor channel IR/MW use idum varch polarisation(0:vertical;1:horizontal) + 1023 7 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 8 1 1 0 5.0000000000E+00 0.0000000000E+00 10.00000 9.00000 + 1023 9 1 1 0 5.0000000000E+00 0.0000000000E+00 16.00000 15.00000 + 1023 10 1 1 0 5.0000000000E+00 0.0000000000E+00 21.00000 19.00000 + 1023 11 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 12 1 -1 0 10.0000000000E+00 0.0000000000E+00 30.00000 8.00000 + 1023 13 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 14 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 15 1 -1 0 5.0000000000E+00 0.0000000000E+00 40.00000 8.00000 + 1023 16 1 -1 0 5.0000000000E+00 0.0000000000E+00 30.00000 8.00000 diff --git a/wrftladj/module_microphysics_driver_ad.F b/wrftladj/module_microphysics_driver_ad.F index de436b2263..ead30bf2cc 100755 --- a/wrftladj/module_microphysics_driver_ad.F +++ b/wrftladj/module_microphysics_driver_ad.F @@ -55,8 +55,7 @@ SUBROUTINE A_MICROPHYSICS_DRIVER(th, thb, rho, rhob, pi_phy, pi_phyb, p& USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & ,WSM6SCHEME, WSM6RSCHEME, ETAMPNEW, THOMPSON, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN & - ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM & ,MILBRANDT2MOM, LSCONDSCHEME, MKESSLERSCHEME, CAMMGMPSCHEME, NTU !,MILBRANDT3MOM, ntu3m ! Model Layer @@ -77,7 +76,6 @@ SUBROUTINE A_MICROPHYSICS_DRIVER(th, thb, rho, rhob, pi_phy, pi_phyb, p& IMPLICIT NONE -! ,NSSL_3MOM & !,MILBRANDT3MOM ! Model Layer ! *** add new modules of schemes here diff --git a/wrftladj/module_microphysics_driver_tl.F b/wrftladj/module_microphysics_driver_tl.F index ea57bfbb4d..2562f4d5ae 100755 --- a/wrftladj/module_microphysics_driver_tl.F +++ b/wrftladj/module_microphysics_driver_tl.F @@ -51,8 +51,7 @@ SUBROUTINE G_MICROPHYSICS_DRIVER(th, thd, rho, rhod, pi_phy, pi_phyd, p& USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & ,WSM6SCHEME, WSM6RSCHEME, ETAMPNEW, THOMPSON, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG & - ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM & ,MILBRANDT2MOM, LSCONDSCHEME, MKESSLERSCHEME, CAMMGMPSCHEME, NTU !,MILBRANDT3MOM, ntu3m ! Model Layer @@ -72,7 +71,6 @@ SUBROUTINE G_MICROPHYSICS_DRIVER(th, thd, rho, rhod, pi_phy, pi_phyd, p& IMPLICIT NONE -! ,NSSL_3MOM & !,MILBRANDT3MOM ! Model Layer ! *** add new modules of schemes here diff --git a/wrftladj/module_pbl_driver_ad.F b/wrftladj/module_pbl_driver_ad.F index 27fc22efbe..3001a38490 100644 --- a/wrftladj/module_pbl_driver_ad.F +++ b/wrftladj/module_pbl_driver_ad.F @@ -502,6 +502,10 @@ SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& REAL :: seamask, thsk, zzz, unew, vnew, tnew, qnew, umom, vmom REAL :: z0, z1, z2, w1, w2 !------------------------------------------------------------------ +! For shared physics + REAL, DIMENSION(ims:ime, jms:jme) :: dx2dtmp + character*256 :: errmsg + integer :: errflg ! !!!!!!!if using BEP set flag_bep to true INTEGER :: branch @@ -635,6 +639,7 @@ SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& ELSE CALL PUSHCONTROL1B(1) END IF + dx2dtmp(i,j)=dx END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) @@ -677,8 +682,9 @@ SUBROUTINE A_PBL_DRIVER(itimestep, dt, u_frame, v_frame, bldt, curr_secs& & oc12d=oc12d, oa2d1=oa1, oa2d2=oa2, oa2d3=oa3, oa2d4=oa4& & , ol2d1=ol1, ol2d2=ol2, ol2d3=ol3, ol2d4=ol4, & & SINA=sina,COSA=cosa, znu=znu, & +& errmsg= errmsg, errflg=errflg, & & znw=znw, p_top=p_top, cp=cp, g=g, rd=r_d, rv=& -& r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=dx, kpbl2d=& +& r_v, ep1=ep_1, pi=3.141592653, dt=dtbl, dx=dx2dtmp, kpbl2d=& & kpbl, itimestep=itimestep, 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, & diff --git a/wrftladj/solve_em_ad.F b/wrftladj/solve_em_ad.F index c2ec4f5eed..5acb79d4d8 100644 --- a/wrftladj/solve_em_ad.F +++ b/wrftladj/solve_em_ad.F @@ -4015,6 +4015,7 @@ SUBROUTINE solve_em_ad ( grid , config_flags & jts = max(grid%j_start(ij),jds) jte = min(grid%j_end(ij),jde-1) + IF ( config_flags%mp_zero_out > 0 ) THEN CALL microphysics_zero_outb ( & moist , num_moist , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4022,6 +4023,7 @@ SUBROUTINE solve_em_ad ( grid , config_flags & its, ite, jts, jte, & k_start , k_end ) + IF ( config_flags%mp_zero_out_all > 0 ) THEN CALL microphysics_zero_outb ( & scalar , num_scalar , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4042,6 +4044,8 @@ SUBROUTINE solve_em_ad ( grid , config_flags & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + ENDIF + ENDIF IF ( config_flags%periodic_x ) THEN its = max(grid%i_start(ij),ids) @@ -4054,6 +4058,7 @@ SUBROUTINE solve_em_ad ( grid , config_flags & jte = min(grid%j_end(ij),jde-1-sz) CALL PUSHREAL8ARRAY ( moist, (ime-ims+1)*(kme-kms+1)*(jme-jms+1)*num_moist ) + IF ( config_flags%mp_zero_out > 0 ) THEN CALL microphysics_zero_outa ( & moist , num_moist , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4061,6 +4066,7 @@ SUBROUTINE solve_em_ad ( grid , config_flags & its, ite, jts, jte, & k_start , k_end ) + IF ( config_flags%mp_zero_out_all > 0 ) THEN CALL microphysics_zero_outa ( & scalar , num_scalar , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -4081,6 +4087,8 @@ SUBROUTINE solve_em_ad ( grid , config_flags & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + ENDIF + ENDIF CALL PUSHREAL8ARRAY ( grid%t_2, (ime-ims+1)*(kme-kms+1)*(jme-jms+1) ) CALL PUSHREAL8ARRAY ( grid%h_diabatic, (ime-ims+1)*(kme-kms+1)*(jme-jms+1) ) diff --git a/wrftladj/solve_em_tl.F b/wrftladj/solve_em_tl.F index a8c323a607..e669c47a8b 100644 --- a/wrftladj/solve_em_tl.F +++ b/wrftladj/solve_em_tl.F @@ -3654,6 +3654,7 @@ SUBROUTINE solve_em_tl ( grid , config_flags & jts = max(grid%j_start(ij),jds) jte = min(grid%j_end(ij),jde-1) + IF ( config_flags%mp_zero_out > 0 ) THEN CALL g_microphysics_zero_outb ( & moist , g_moist, num_moist , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -3661,6 +3662,7 @@ SUBROUTINE solve_em_tl ( grid , config_flags & its, ite, jts, jte, & k_start , k_end ) + IF ( config_flags%mp_zero_out_all > 0 ) THEN CALL g_microphysics_zero_outb ( & scalar , g_scalar, num_scalar , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -3682,6 +3684,8 @@ SUBROUTINE solve_em_tl ( grid , config_flags & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + ENDIF + ENDIF IF ( config_flags%periodic_x ) THEN its = max(grid%i_start(ij),ids) @@ -3693,6 +3697,7 @@ SUBROUTINE solve_em_tl ( grid , config_flags & jts = max(grid%j_start(ij),jds+sz) jte = min(grid%j_end(ij),jde-1-sz) + IF ( config_flags%mp_zero_out > 0 ) THEN CALL g_microphysics_zero_outa ( & moist , g_moist, num_moist , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -3700,6 +3705,7 @@ SUBROUTINE solve_em_tl ( grid , config_flags & its, ite, jts, jte, & k_start , k_end ) + IF ( config_flags%mp_zero_out_all > 0 ) THEN CALL g_microphysics_zero_outa ( & scalar ,g_scalar, num_scalar , config_flags , & ids, ide, jds, jde, kds, kde, & @@ -3721,6 +3727,8 @@ SUBROUTINE solve_em_tl ( grid , config_flags & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + ENDIF + ENDIF CALL g_moist_physics_finish_em( grid%t_2, grid%g_t_2, grid%t_1, & t0, grid%muts, &