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..714647744e --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,921 @@ +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_KPP OFF CACHE BOOL "ENABLE_KPP" ) +set( ENABLE_DFI_RADAR OFF CACHE BOOL "ENABLE_DFI_RADAR" ) +set( ENABLE_TITAN OFF CACHE BOOL "ENABLE_TITAN" ) +set( ENABLE_MARS OFF CACHE BOOL "ENABLE_MARS" ) +set( ENABLE_VENUS OFF CACHE BOOL "ENABLE_VENUS" ) +set( ENABLE_VENUS OFF CACHE BOOL "ENABLE_VENUS" ) +set( ENABLE_TERRAIN OFF CACHE BOOL "ENABLE_TERRAIN" ) +set( ENABLE_CTSM OFF CACHE BOOL "ENABLE_CTSM" ) + +# 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() + + +# 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_CMAQ 20 ) +print_option( ENABLE_KPP 20 ) +print_option( ENABLE_DFI_RADAR 20 ) +print_option( ENABLE_TITAN 20 ) +print_option( ENABLE_MARS 20 ) +print_option( ENABLE_VENUS 20 ) +print_option( ENABLE_VENUS 20 ) +print_option( ENABLE_TERRAIN 20 ) +print_option( ENABLE_CLM 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=$> + + # 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() + +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 + ) \ No newline at end of file diff --git a/README b/README index 30879e360b..0dc23906b0 100644 --- a/README +++ b/README @@ -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/configure.defaults b/arch/configure.defaults index 36ca1b6e00..1275f3ce33 100644 --- a/arch/configure.defaults +++ b/arch/configure.defaults @@ -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,7 +862,7 @@ 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 @@ -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 @@ -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,7 +1739,7 @@ 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 @@ -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 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 936f0405c8..aa55662073 100644 --- a/arch/postamble +++ b/arch/postamble @@ -203,6 +203,13 @@ wrfio_esmf : 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) $@ @@ -211,6 +218,13 @@ wrfio_esmf : $(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 + .f90.o: $(RM) $@ $(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90 diff --git a/arch/preamble b/arch/preamble index 4543411e6f..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. 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..d393dfe36b 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] --version 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] -V + 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 41243e2813..5e2bedb10f 100755 --- a/configure +++ b/configure @@ -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 @@ -219,6 +219,8 @@ if [ -n "$NETCDFPAR" ] ; then export NETCDF export NETCDF4 export USENETCDFPAR +else + export USENETCDFPAR=0 fi if test -z "$NETCDF" ; then @@ -657,7 +659,7 @@ fi #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}'` 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 62f4fafaa6..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 !--------------------------------------------------------------------------------- @@ -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 !--------------------------------------------------------------------------------- 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_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..dab6198849 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. @@ -1181,6 +1190,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 +1249,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 +1349,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 +1362,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 +1733,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 +1820,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 ( flag_sh .ne. 1 .or. flag_qv .ne. 1 .or. .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 +1843,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 +3134,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 +3167,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 +3201,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 +4100,7 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + IF ( flag_sh .ne. 1 .or. flag_qv .ne. 1 .or. .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 +4122,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 +7867,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 +7983,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 941b64a1c5..97a5bfcdcf 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/rsl_bcast.c b/external/RSL_LITE/rsl_bcast.c index 88c03c944b..28c6725d7e 100755 --- a/external/RSL_LITE/rsl_bcast.c +++ b/external/RSL_LITE/rsl_bcast.c @@ -532,7 +532,6 @@ void RSL_LITE_TO_PARENT_MSG ( nbuf_p, buf ) // // nest if it's parent->nest and the parent if it's nest->parent (we'll see) - /* common code */ 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 ; 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/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_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/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/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_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/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/streams.h b/inc/streams.h index 645b02d855..f7fe57d98e 100644 --- a/inc/streams.h +++ b/inc/streams.h @@ -1,5 +1,11 @@ #ifndef MAX_HISTORY -# define MAX_HISTORY 12 +# include +# define MAX_HISTORY (UINT8_C(12)) +# if (MAX_HISTORY > 120) +# warning If changing MAX_HISTORY to be above 120, check uses, loop variables, +# warning and destination string buffers to ensure the types used are wide +# warning enough. Enabling compiler warnings for format strings should help. +# endif #endif #ifndef IWORDSIZE # define IWORDSIZE 4 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 293dfd4df8..ff6211df94 100644 --- a/main/depend.common +++ b/main/depend.common @@ -1,1334 +1,2856 @@ # 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 - -module_timing.o: hires_timer.o clog.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 + ../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_comm_dm_0.o: \ + module_driver_constants.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_cu_kfeta.o: ../frame/module_wrf_error.o - -module_cu_gd.o: - -module_cu_ksas.o: - -module_cu_nsas.o: - -module_cu_du.o: ../frame/module_wrf_error.o - -module_gfs_physcons.o: module_gfs_machine.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_gfs_funcphys.o: module_gfs_machine.o \ - module_gfs_physcons.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_sf_mynn.o: \ + module_sf_sfclay.o \ + module_bl_mynn.o \ + ../share/module_model_constants.o \ + ../frame/module_wrf_error.o -module_cu_osas.o: module_gfs_machine.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_sf_fogdes.o: \ + ../share/module_model_constants.o -module_cu_ntiedtke.o: ../share/module_model_constants.o -module_ra_gfdleta.o: ../frame/module_dm.o \ - module_mp_etanew.o +module_bl_fogdes.o: \ + ../share/module_model_constants.o -module_ra_rrtm.o: ../frame/module_wrf_error.o \ - module_ra_clWRF_support.o \ - ../frame/module_dm.o -module_ra_cam_support.o: module_cam_support.o \ - ../frame/module_wrf_error.o +module_sf_gfdl.o: \ + module_gfs_machine.o \ + module_sf_exchcoef.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.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_mp_lin.o : ../frame/module_wrf_error.o \ - module_mp_radar.o +module_cu_bmj.o: \ + ../share/module_model_constants.o -module_ra_flg.o: ../frame/module_wrf_error.o \ - ../frame/module_dm.o -module_mp_sbu_ylin.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.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_mp_milbrandt2mom.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o -module_mp_thompson.o : ../frame/module_wrf_error.o \ - module_mp_radar.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_nssl_2mom.o : ../frame/module_wrf_error.o \ - ../share/module_model_constants.o -module_mp_fast_sbm.o : module_mp_radar.o +module_shcu_deng.o: \ + ../frame/module_wrf_error.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_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_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_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_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_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_mp_qneg3.o: module_cam_shr_kind_mod.o \ - module_cam_support.o +module_cam_error_function.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_mp_gsfcgce.o : ../frame/module_wrf_error.o \ - module_mp_radar.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_sf_myjsfc.o: ../share/module_model_constants.o -module_sf_qnsesfc.o: ../share/module_model_constants.o +module_cam_esinti.o: \ + module_cam_shr_kind_mod.o \ + module_cam_wv_saturation.o -module_sf_gfs.o: module_gfs_machine.o \ - module_gfs_funcphys.o \ - module_gfs_physcons.o \ - module_progtm.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_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_noahlsm.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_cam_gffgch.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.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_cam_physconst.o: \ + module_cam_shr_kind_mod.o \ + module_cam_shr_const_mod.o -module_sf_noah_seaice_drv.o: module_sf_noah_seaice.o -module_sf_noah_seaice.o: module_sf_noahlsm.o ../share/module_model_constants.o +module_cam_shr_const_mod.o: \ + module_cam_shr_kind_mod.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_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o +module_cam_support.o: \ + ../frame/module_wrf_error.o \ + module_cam_shr_kind_mod.o \ + ../frame/module_state_description.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_sf_bem.o: ../share/module_model_constants.o +module_cam_shr_kind_mod.o: \ -module_sf_ruclsm.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 +module_cu_kf.o: \ + ../frame/module_wrf_error.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_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_kfcup.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + $(CF2) \ + ../share/module_model_constants.o \ + module_mixactivate.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_cu_kfeta.o: \ + ../frame/module_wrf_error.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_shallowcu_driver.o: \ - module_shcu_camuwshcu_driver.o \ - module_shcu_deng.o \ - ../frame/module_state_description.o \ - ../share/module_model_constants.o +module_cu_gd.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_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_ksas.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_cu_nsas.o: \ -module_diagnostics_driver.o: \ - module_lightning_driver.o \ - module_diag_misc.o \ - module_diag_nwp.o \ - module_diag_cl.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_cu_du.o: \ + ../frame/module_wrf_error.o -module_diag_cl.o: \ - ../frame/module_dm.o \ - ../frame/module_configure.o -module_diag_pld.o: \ - ../share/module_model_constants.o +module_gfs_physcons.o: \ + module_gfs_machine.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_gfs_funcphys.o: \ + module_gfs_machine.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_sas.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_scalesas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o -module_diag_refl.o: \ - ../frame/module_dm.o \ - ../share/module_model_constants.o -module_mixactivate.o: \ - module_radiation_driver.o +module_cu_osas.o: \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.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_cu_tiedtke.o: \ + ../share/module_model_constants.o \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.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_cu_ntiedtke.o: \ + ../share/module_model_constants.o \ + ccpp_kind_types.o \ + physics_mmm/cu_ntiedtke.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_gfdleta.o: \ + ../frame/module_configure.o \ + ../share/module_model_constants.o \ + ../frame/module_dm.o \ + module_mp_etanew.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_ra_rrtm.o: \ + ../frame/module_wrf_error.o \ + module_ra_clWRF_support.o \ + ../frame/module_dm.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_cam_support.o: \ + module_cam_support.o \ + ../frame/module_wrf_error.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_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_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_lin.o: \ + ../frame/module_wrf_error.o \ + module_mp_radar.o -module_mp_wsm5.o :\ - module_mp_wsm5_accel.F \ - module_mp_radar.o -module_mp_wdm5.o :\ - module_mp_radar.o +module_ra_flg.o: \ + ../frame/module_wrf_error.o \ + ../frame/module_dm.o -module_mp_wsm6.o :\ - module_mp_radar.o -module_mp_wdm6.o :\ - module_mp_radar.o +module_mp_sbu_ylin.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_milbrandt2mom.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_mp_radar.o : -module_lightning_driver.o : \ - module_ltng_crmpr92.o module_ltng_cpmpr92z.o module_ltng_iccg.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_ltng_cpmpr92z.o : -module_ltng_crmpr92.o : +module_mp_nssl_2mom.o: \ + ../frame/module_wrf_error.o \ + ../share/module_model_constants.o -module_ltng_iccg.o : -module_ra_aerosol.o :\ - ../frame/module_wrf_error.o +module_mp_fast_sbm.o: \ + ../frame/module_domain.o \ + module_mp_SBM_polar_radar.o \ + module_mp_radar.o -module_gocart_coupling.o: -module_ra_goddard.o : ../frame/module_wrf_error.o \ - module_gocart_coupling.o \ - module_checkerror.o +module_mp_full_sbm.o: \ + module_mp_radar.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_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 -# DEPENDENCIES for share +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_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_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 -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_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_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_modal_aero_initialize_data_phys.o: \ + module_data_cam_mam_aero.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_mp_conv_water.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o \ + module_cam_physconst.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_cam_mp_qneg3.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.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_cam_mp_radconstants.o: \ + module_cam_shr_kind_mod.o \ + module_cam_support.o -# End of DEPENDENCIES for share +module_cam_infnan.o: \ + module_cam_shr_kind_mod.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_mp_gsfcgce.o: \ + ../frame/module_wrf_error.o \ + module_mp_radar.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_myjsfc.o: \ + ../share/module_model_constants.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_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 + + +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 + -# End of DEPENDENCIES for main +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 \ + module_sf_sfclayrev.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_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_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_sf_bep.o: \ + module_sf_urban.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 e9974cd3f1..a7fb3dafe4 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_irrigation.o @@ -231,6 +233,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 @@ -239,11 +251,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..fca1f33a31 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 :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) - REAL, 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) - 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 @@ -2095,18 +2001,18 @@ SUBROUTINE mym_length ( & ugrid = sqrt(u1(kts)**2 + v1(kts)**2) uonset= 15. wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) - cns = 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 + cns = 2.7 !was 3.5 + alp1 = 0.23 + alp2 = 0.3 + alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,200.) !minzi) - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) ! 1/2 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 @@ -2139,7 +2045,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. ** @@ -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) + bv = max( sqrt( gtr*dtv(k) ), 0.0001) elb = MAX(alp2*qkw(k), & & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) - elf = 0.65 * qkw(k)/bv + elf = 1.0 * qkw(k)/bv elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 @@ -2179,8 +2085,10 @@ 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))) + !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 @@ -2194,20 +2102,20 @@ 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 @@ -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.002) + 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) @@ -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 + 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,163 @@ 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 !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 +6087,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 +6118,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 +6131,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 +6145,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 +6189,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 +6314,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 +6367,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 +6387,104 @@ 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 +END IF !end criteria check 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 - - 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 + 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 + 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 +6496,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) +rhoz(k)*UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +rhoz(k)*UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+rhoz(k)*UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+rhoz(k)*UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +rhoz(k)*UPA(K,i)*UPQC(K,i) + enddo + enddo + do k=kts,kte-1 !Note that only edmf_a is multiplied by Psig_w. This takes care of the !scale-awareness of the subsidence below: - IF (edmf_a(k)>0.) THEN - edmf_w(k)=edmf_w(k)/edmf_a(k) - edmf_qt(k)=edmf_qt(k)/edmf_a(k) - edmf_thl(k)=edmf_thl(k)/edmf_a(k) - edmf_ent(k)=edmf_ent(k)/edmf_a(k) - edmf_qc(k)=edmf_qc(k)/edmf_a(k) - edmf_a(k)=edmf_a(k)*Psig_w - - !FIND MAXIMUM MASS-FLUX IN THE COLUMN: - IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) - ENDIF - ENDDO ! end k - - !smoke/chem - IF ( mix_chem ) THEN - DO k=kts,kte-1 - 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 +6581,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 +6600,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 +6616,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 +6645,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 +6685,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 +6706,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 +6721,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 +6744,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 +6830,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 +6877,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 +6892,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 +6941,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 +7061,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 +7072,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 +7094,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 +7139,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 +7174,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 +7222,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 +7272,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 +7321,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 +7395,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 +7440,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 +7504,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 +7515,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 +7533,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 +7554,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 +7585,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 +7606,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 +7624,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,wm2,wm3,bfxpbl,dthvx,tmp1 + real(kind_phys) :: temps,templ,zl1,wstar3_2 + real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 integer :: k,kk,kminrad logical :: cloudflg @@ -7704,15 +7708,15 @@ 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 + wm2 = wm2 + wm3**twothirds 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 +7724,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_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 42c29f49d2..aa583b505f 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 @@ -410,9 +409,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 & @@ -460,6 +460,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 & @@ -509,6 +510,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 & @@ -560,6 +562,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 & @@ -605,57 +608,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 & @@ -715,8 +672,6 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ! CASE (ETAMPNEW) -! CASE (NSSL_3MOM) - ! CASE (MILBRANDT3MOM) ! CASE (MORR_MILB_P3) @@ -734,6 +689,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..b2182998fe 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! @@ -799,7 +806,7 @@ SUBROUTINE microphysics_driver( & ENDIF ! set this to true to print out the global max/min for W on each time step. - IF ( .false. ) THEN + IF ( .true. ) THEN wmax = maxval( w(ips:ipe,kps:kpe,jps:jpe) ) wmin = minval( w(ips:ipe,kps:kpe,jps:jpe) ) #if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) @@ -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 f0600fea85..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 ! +-----------------------------------------------------------------------------+ ! +-----------------------------------------------------------------------------+ 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_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..cb741d0719 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 @@ -3709,14 +3698,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 +4371,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 +4380,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 +4400,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 +4416,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 +4447,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 +4470,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 +4483,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 +4602,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 +5662,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_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 cd1d097c77..c770dddccc 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 @@ -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 & @@ -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_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/noahmp b/phys/noahmp index 981d4f859c..848f54ad3d 160000 --- a/phys/noahmp +++ b/phys/noahmp @@ -1 +1 @@ -Subproject commit 981d4f859ce6c64213d38a783654c05b47b3485e +Subproject commit 848f54ad3d28c4303151fe5ad83724e232694422 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..d91c9a72df --- /dev/null +++ b/phys/physics_mmm/cu_ntiedtke.F90 @@ -0,0 +1,3585 @@ +!================================================================================================================= + 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 + + +!================================================================================================================= + 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 + +!================================================================================================================= + 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 + +!================================================================================================================= +! 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..0041adfadc --- /dev/null +++ b/phys/physics_mmm/mp_wsm6_effectRad.F90 @@ -0,0 +1,188 @@ +!================================================================================================================= + 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 + + +!================================================================================================================= + 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 + +!================================================================================================================= + 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 + +!================================================================================================================= + 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/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/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..98acad8d8f 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -1,9 +1,9 @@ .SUFFIXES: .c .o -CC_TOOLS = cc +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 \ @@ -30,21 +30,22 @@ gen_comms.c : gen_comms.stub # DO NOT DELETE THIS LINE -- make depend depends on it. -data.o: registry.h protos.h data.h -gen_allocs.o: protos.h registry.h data.h -gen_args.o: protos.h registry.h data.h -gen_scalar_derefs.o: protos.h registry.h data.h -gen_config.o: protos.h registry.h data.h -gen_defs.o: protos.h registry.h data.h -gen_mod_state_descr.o: protos.h registry.h data.h -gen_model_data_ord.o: protos.h registry.h data.h -gen_scalar_indices.o: protos.h registry.h data.h -gen_wrf_io.o: protos.h registry.h data.h -misc.o: protos.h registry.h data.h -my_strtok.o: registry.h protos.h data.h -reg_parse.o: registry.h protos.h data.h -registry.o: protos.h registry.h data.h +data.o: registry.h protos.h data.h ../inc/streams.h +gen_allocs.o: protos.h registry.h data.h ../inc/streams.h sym.h +gen_args.o: protos.h registry.h data.h ../inc/streams.h +gen_config.o: protos.h registry.h data.h ../inc/streams.h sym.h +gen_defs.o: protos.h registry.h data.h ../inc/streams.h +gen_interp.o: protos.h registry.h data.h ../inc/streams.h +gen_mod_state_descr.o: protos.h registry.h data.h ../inc/streams.h +gen_model_data_ord.o: protos.h registry.h data.h ../inc/streams.h +gen_scalar_derefs.o: protos.h registry.h data.h ../inc/streams.h +gen_scalar_indices.o: protos.h registry.h data.h ../inc/streams.h +gen_streams.o: protos.h registry.h data.h ../inc/streams.h sym.h +gen_wrf_io.o: protos.h registry.h data.h ../inc/streams.h sym.h +misc.o: protos.h registry.h data.h ../inc/streams.h +my_strtok.o: registry.h protos.h data.h ../inc/streams.h +reg_parse.o: registry.h protos.h data.h ../inc/streams.h sym.h +registry.o: protos.h registry.h data.h ../inc/streams.h sym.h +set_dim_strs.o: protos.h registry.h data.h ../inc/streams.h sym.h sym.o: sym.h -type.o: registry.h protos.h data.h -gen_interp.o: registry.h protos.h data.h -gen_streams.o: registry.h protos.h data.h +type.o: registry.h protos.h data.h ../inc/streams.h diff --git a/tools/data.h b/tools/data.h index 081ece8616..c609788c03 100644 --- a/tools/data.h +++ b/tools/data.h @@ -119,7 +119,7 @@ EXTERN node_t * Cycles ; EXTERN node_t Domain ; -EXTERN char t1[NAMELEN], t2[NAMELEN], t3[NAMELEN], t4[NAMELEN], t5[NAMELEN], t6[NAMELEN] ; +EXTERN char t1[NAMELEN + EXTRA_FOR_DEST_BUFFER], t2[NAMELEN], t3[NAMELEN], t4[NAMELEN + EXTRA_FOR_DEST_BUFFER], t5[NAMELEN], t6[NAMELEN] ; EXTERN char thiscom[4*NAMELEN] ; EXTERN int model_order[3] ; diff --git a/tools/fseek_test.c b/tools/fseek_test.c index edd25c6035..7cbe2ecf1b 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 @@ -8,7 +11,7 @@ main() FILE *fp ; long long y ; int retval ; - int result1 ; + int result1 = 0 ; #ifdef TEST_FSEEKO off_t x ; off_t result2 ; @@ -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..0e3a0fa927 100644 --- a/tools/gen_allocs.c +++ b/tools/gen_allocs.c @@ -80,13 +80,13 @@ int gen_alloc2 ( FILE * fp , char * structname , char * structname2 , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ) /* 1 = allocate, 2 = just count */ { node_t * p ; - int tag ; - char post[NAMELEN], post_for_count[NAMELEN] ; - char fname[NAMELEN], dname[NAMELEN], dname_tmp[NAMELEN] ; - char x[NAMELEN] ; - char x2[NAMELEN], fname2[NAMELEN] ; - char dimname[3][NAMELEN] ; - char tchar ; + int tag = 0 ; + char post[NAMELEN + 2 * EXTRA_FOR_DEST_BUFFER], post_for_count[NAMELEN + 2 * EXTRA_FOR_DEST_BUFFER] ; + char fname[NAMELEN], dname[NAMELEN + EXTRA_FOR_DEST_BUFFER], dname_tmp[NAMELEN] ; + char x[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + char x2[NAMELEN + EXTRA_FOR_DEST_BUFFER], fname2[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + char dimname[3][NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + char tchar = '\0'; unsigned int *io_mask ; int nd ; int restart ; @@ -120,7 +120,7 @@ gen_alloc2 ( FILE * fp , char * structname , char * structname2 , node_t * node, */ if ( tag == 1 ) { - char dname_symbol[128] ; + char dname_symbol[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; sym_nodeptr sym_node ; sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ; @@ -544,7 +544,7 @@ gen_ddt_write1 ( FILE * fp , char * structname , node_t * node ) { node_t * p ; int tag ; - char post[NAMELEN] ; + char post[NAMELEN + 2 * EXTRA_FOR_DEST_BUFFER] ; char fname[NAMELEN] ; char x[NAMELEN] ; @@ -605,9 +605,9 @@ gen_dealloc2 ( FILE * fp , char * structname , node_t * node ) { node_t * p ; int tag ; - char post[NAMELEN] ; + char post[NAMELEN + 2 * EXTRA_FOR_DEST_BUFFER] ; char fname[NAMELEN] ; - char x[NAMELEN] ; + char x[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; if ( node == NULL ) return(1) ; @@ -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_args.c b/tools/gen_args.c index ea995d4230..3121ec3947 100644 --- a/tools/gen_args.c +++ b/tools/gen_args.c @@ -88,7 +88,7 @@ gen_args1 ( FILE * fp , char * outstr , char * structname , int tag ; char post[NAMELEN] ; char fname[NAMELEN] ; - char x[NAMELEN], y[NAMELEN] ; + char x[NAMELEN + EXTRA_FOR_DEST_BUFFER], y[NAMELEN] ; char indices[NAMELEN] ; int lenarg ; int only4d = 0 ; diff --git a/tools/gen_config.c b/tools/gen_config.c index c07be2e919..477d3b9bc7 100644 --- a/tools/gen_config.c +++ b/tools/gen_config.c @@ -15,12 +15,16 @@ int gen_namelist_defines ( char * dirname , int sw_dimension ) { FILE * fp ; - char fname[NAMELEN] ; + char fname[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; char fn[NAMELEN] ; node_t *p ; sprintf( fn, "namelist_defines%s.inc", sw_dimension?"":"2" ) ; - if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ( strlen(dirname) > 0 ) { + sprintf(fname,"%s/%s",dirname,fn) ; + } else { + sprintf(fname, "%s", fn) ; + } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; @@ -56,7 +60,11 @@ gen_namelist_defaults ( char * dirname ) char *fn = "namelist_defaults.inc" ; node_t *p ; - if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ( strlen(dirname) > 0 ) { + sprintf(fname,"%s/%s",dirname,fn) ; + } else { + sprintf(fname, "%s", fn) ; + } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; @@ -130,7 +138,11 @@ gen_namelist_script ( char * dirname ) char howset1[NAMELEN] ; char howset2[NAMELEN] ; - if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ( strlen(dirname) > 0 ) { + sprintf(fname,"%s/%s",dirname,fn) ; + } else { + sprintf(fname, "%s", fn) ; + } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; sym_forget() ; diff --git a/tools/gen_defs.c b/tools/gen_defs.c index 020bbac3b7..5010f263e3 100644 --- a/tools/gen_defs.c +++ b/tools/gen_defs.c @@ -90,7 +90,7 @@ int gen_i1_decls ( char * dn ) { FILE * fp ; - char fname[NAMELEN], post[NAMELEN] ; + char fname[NAMELEN+EXTRA_FOR_DEST_BUFFER], post[NAMELEN+EXTRA_FOR_DEST_BUFFER] ; char * fn = "i1_decl.inc" ; char * dimspec ; node_t * p ; @@ -139,8 +139,8 @@ gen_decls ( FILE * fp , node_t * node , int sw_ranges, int sw_point , int mask , { node_t * p ; int tag, ipass ; - char fname[NAMELEN], post[NAMELEN] ; - char * dimspec ; + char fname[NAMELEN], post[NAMELEN + 2 * EXTRA_FOR_DEST_BUFFER] ; + char * dimspec = ""; int bdyonly = 0 ; if ( node == NULL ) return(1) ; diff --git a/tools/gen_interp.c b/tools/gen_interp.c index a4a504228c..f905a11512 100644 --- a/tools/gen_interp.c +++ b/tools/gen_interp.c @@ -66,7 +66,7 @@ int contains_tok( char *s1, char *s2, char *delims ) /* Had to increase size for SOA from 4*4096 to 4*7000 */ -char halo_define[4*7000], halo_use[NAMELEN], halo_id[NAMELEN], x[NAMELEN] ; +char halo_define[4*7000], halo_use[NAMELEN] = {'\0'}, halo_id[NAMELEN], x[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER] ; /*KAL added this for vertical interpolation */ /*DJW 131202 modified to create files required for vertical interpolation from parent to nest */ @@ -130,7 +130,7 @@ else if ( down_path[ipath] == FORCE_DOWN ) { sprintf(halo_id,"HALO_FORCE_DOWN") else if ( down_path[ipath] == INTERP_UP ) { sprintf(halo_id,"HALO_INTERP_UP") ; } else if ( down_path[ipath] == SMOOTH_UP ) { sprintf(halo_id,"HALO_INTERP_SMOOTH") ; } sprintf(halo_define,"80:") ; -sprintf(halo_use,"") ; + halo_use[0] = '\0' ; gen_nest_interp1 ( fp , Domain.fields, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 ) ; { node_t * comm_struct ; @@ -168,15 +168,15 @@ gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , char nddim2[3][2][NAMELEN] ; char nmdim2[3][2][NAMELEN] ; char npdim2[3][2][NAMELEN] ; - char vname[NAMELEN], vname2[NAMELEN] ; - char tag[NAMELEN], tag2[NAMELEN] ; + char vname[3 * NAMELEN + 5 * EXTRA_FOR_DEST_BUFFER], vname2[3 * NAMELEN + 5 * EXTRA_FOR_DEST_BUFFER] ; + char tag[NAMELEN] = {'\0'}, tag2[NAMELEN] = {'\0'} ; char fcn_name[NAMELEN] ; char xstag[NAMELEN], ystag[NAMELEN] ; char dexes[NAMELEN] ; char ndexes[NAMELEN] ; char *maskstr ; char *grid ; - char *colon, r[10],tx[80],temp[80],moredims[80] ; + char *colon, r[10],tx[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER],temp[80],moredims[80] ; int d ; double real_store; long long_store; @@ -200,7 +200,7 @@ gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , if ( nest_mask & down_path ) { if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; } - else { sprintf(tag,"") ; sprintf(tag2,"") ; } + else { tag[0] = '\0'; tag2[0] = '\0'; } /* construct variable name */ if ( p->node_kind & FOURD ) { @@ -359,7 +359,7 @@ fprintf(fp," ngrid%%i_parent_start, ngrid%%j_parent_start, fprintf(fp," ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio &\n") ; { - char tmpstr[NAMELEN], *p1 ; + char tmpstr[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER], *p1 ; node_t * nd, * pp ; pp = NULL ; if ( p->node_kind & FOURD ) { @@ -377,10 +377,10 @@ 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 ) { - sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name ) ; + if ( ! (p->node_kind & FOURD) ) { + snprintf( tmpstr , 2 * NAMELEN + EXTRA_FOR_DEST_BUFFER, "%s_b,%s_bt,", pp->name, pp->name ) ; } else { - sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name ) ; + snprintf( tmpstr , 2 * NAMELEN + EXTRA_FOR_DEST_BUFFER, "%s_b,%s_bt,", p->name, p->name ) ; } strcat( tmpstr , pp->force_aux_fields ) ; } else if ( down_path & INTERP_DOWN ) { @@ -507,12 +507,12 @@ gen_nest_interp2 ( FILE * fp , node_t * node, char * fourdname, int down_path , char ddim[3][2][NAMELEN] ; char mdim[3][2][NAMELEN] ; char pdim[3][2][NAMELEN] ; - char vname[NAMELEN], vname2[NAMELEN] ; + char vname[3 * NAMELEN + 5 * EXTRA_FOR_DEST_BUFFER], vname2[3 * NAMELEN + 5 * EXTRA_FOR_DEST_BUFFER] ; char tag[NAMELEN], tag2[NAMELEN] ; char dexes[NAMELEN] ; char ndexes[NAMELEN] ; char *grid ; - char *colon,r[10],tx[80],temp[80],moredims[80] ; + char *colon,r[10],tx[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER],temp[80],moredims[80] ; int d ; char zstag[NAMELEN]; char fcn_name[NAMELEN]; @@ -546,11 +546,11 @@ 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,"") ; } + else { tag[0] = '\0'; tag2[0] = '\0'; } /* construct variable name */ if ( p->node_kind & FOURD ) { diff --git a/tools/gen_irr_diag.c b/tools/gen_irr_diag.c index 13071f239f..4ccc024940 100644 --- a/tools/gen_irr_diag.c +++ b/tools/gen_irr_diag.c @@ -7,10 +7,15 @@ #include #include +#define TABLE_ENTRY 128 +#define EXTRA_FOR_DEST_BUFFER 32 + +#define NAMELEN 256 + int nChmOpts = 0; -char rxt_tbl[5][1000][128]; -char chm_scheme[5][128]; -int rxt_cnt[5]; +char rxt_tbl[5][1000][TABLE_ENTRY] = { '\0' }; +char chm_scheme[5][TABLE_ENTRY] = { '\0' }; +short int rxt_cnt[5] = {0, 0}; void strip_blanks( char *instring, char *outstring ) { @@ -39,13 +44,13 @@ int AppendReg( char *chem_opt, int ndx ) char *strt, *end; char *token; char *wstrg1; - char path[256]; - char fname[256]; + char path[NAMELEN * 2 + EXTRA_FOR_DEST_BUFFER]; + char fname[NAMELEN]; char inln[1024],winln[1024],s[1024]; - char rxtstr[128]; - char rxtstr_tbl[1000][128]; - char buffer[128]; - char rxtsym[128]; + char rxtstr[TABLE_ENTRY]; + char rxtstr_tbl[1000][TABLE_ENTRY]; + char buffer[TABLE_ENTRY]; + char rxtsym[TABLE_ENTRY]; FILE *fp_eqn, *fp_reg; strcpy( fname,chem_opt ); @@ -72,6 +77,7 @@ int AppendReg( char *chem_opt, int ndx ) if( fp_reg == NULL ) { fprintf(stderr,"Can not open registry.irr_diag for writing\n"); + fclose(fp_eqn); return(-2); } strcpy( buffer,"\"Integrated Reaction Rate\" \"\""); @@ -176,7 +182,7 @@ int AppendReg( char *chem_opt, int ndx ) for( i=0; i < slen; i++ ) { if( ! strncmp( rxtsym+i, "+", 1 ) ) - strncpy( rxtsym+i, "_", 1 ); + strncpy( rxtsym+i, "_", 2 ); } strcat( rxtsym,"_IRR" ); // @@ -202,11 +208,11 @@ int AppendReg( char *chem_opt, int ndx ) int irr_diag_scalar_indices( char *dirname ) { int Nrxt; - int i, j; + short int i, j; int first, flush, s1; char fname[256]; - char line[132]; - char piece[132]; + char line[5 * TABLE_ENTRY + 2 * EXTRA_FOR_DEST_BUFFER]; + char piece[TABLE_ENTRY + EXTRA_FOR_DEST_BUFFER]; char *blank = " "; FILE *fp_inc; @@ -255,30 +261,29 @@ int irr_diag_scalar_indices( char *dirname ) strcat( line,piece ); } strcat( line," /)\n" ); - fprintf( fp_inc,line ); - fprintf( fp_inc," \n"); + fprintf( fp_inc,"%s \n", line); for( i = 0; i < nChmOpts; i++ ) { - sprintf( line," chm_opts_name(%d) = '%s'\n",i+1,chm_scheme[i]); - fprintf( fp_inc,line ); + /* I don't see the point of saving this in line when line get + overwritten immediately afterwards */ + fprintf(fp_inc, " chm_opts_name(%d) = '%s'\n",i+1,chm_scheme[i]); } fprintf( fp_inc," \n"); sprintf( line," chm_opts_ndx(:nchm_opts) = (/ "); for( i = 0; i < nChmOpts; i++ ) { if( i == 0 ) - sprintf( piece,"%s_kpp",chm_scheme[i]); + snprintf( piece,TABLE_ENTRY+EXTRA_FOR_DEST_BUFFER,"%.*s_kpp", TABLE_ENTRY, chm_scheme[i]); else - sprintf( piece," ,%s_kpp",chm_scheme[i]); + snprintf( piece,TABLE_ENTRY+EXTRA_FOR_DEST_BUFFER," ,%.*s_kpp", TABLE_ENTRY, chm_scheme[i]); strcat( line,piece ); } strcat( line," /)\n" ); - fprintf( fp_inc,line ); - fprintf( fp_inc," \n"); + fprintf( fp_inc,"%s \n", line); - 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]); + snprintf( line, TABLE_ENTRY + EXTRA_FOR_DEST_BUFFER, " rxtsym(%d,%d) = '%s'\n",j+1,i+1,rxt_tbl[i][j]); fprintf( fp_inc,"%s",line); } fprintf( fp_inc," \n"); diff --git a/tools/gen_scalar_indices.c b/tools/gen_scalar_indices.c index a24d75ee3c..4a563f59d5 100644 --- a/tools/gen_scalar_indices.c +++ b/tools/gen_scalar_indices.c @@ -14,18 +14,24 @@ #define NULLCHARPTR (char *) 0 +/* About the only place the stringify macro is useful is in the + definition of the stringify_const macro. Most other places, you + can put the quotes on yourself. */ +#define stringify_const(value) stringify(value) +#define stringify(value) #value + int gen_scalar_indices ( char * dirname ) { FILE * fp, *fp5[26] ; - char fname[NAMELEN], fname5[NAMELEN] ; + char fname[NAMELEN], fname5[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER] ; char * fn = "scalar_indices.inc" ; char * fn2 = "scalar_tables.inc" ; char * fn3 = "scalar_tables_init.inc" ; char * fn4 = "scalar_indices_init.inc" ; int i ; - char fn5[26][NAMELEN] ; + char fn5[26][NAMELEN] = { '\0' } ; strcpy( fname, fn ) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } @@ -37,7 +43,14 @@ gen_scalar_indices ( char * dirname ) { sprintf(fn5[i],"in_use_for_config_%c.inc",'a'+i) ; strcpy( fname5, fn5[i] ) ; - if ( strlen(dirname) > 0 ) { sprintf(fname5,"%s/%s",dirname,fn5[i]) ; } + if ( strlen(dirname) > 0 ) { + /* The stringify_const(NAMELEN) is to get something like %.512s + in the format string, so snprintf won't copy more than + NAMELEN elements of the entry of fn5 (each NAMELEN chars long) */ + snprintf(fname5,sizeof(fname5),"%s/%." stringify_const(NAMELEN) "s",dirname,fn5[i]) ; + } else { + snprintf(fname5, NAMELEN + 1, "%." stringify_const(NAMELEN) "s", fn5[i]); + } if ((fp5[i] = fopen( fname5 , "w" )) == NULL ) return(1) ; print_warning(fp5[i],fname5) ; } @@ -117,7 +130,7 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 ) node_t * p, * memb , * pkg, * rconfig, * fourd, *x ; char * c , *pos1, *pos2 ; char assoc_namelist_var[NAMELEN], assoc_namelist_choice[NAMELEN], assoc_4d[NAMELEN_LONG], fname[NAMELEN_LONG] ; - char fname2[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ; + char fname2[NAMELEN], tmp1[NAMELEN + EXTRA_FOR_DEST_BUFFER], tmp2[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; char scalars_str[NAMELEN_LONG] ; char * scalars ; int i ; @@ -128,8 +141,11 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 ) for ( p = FourD ; p != NULL ; p = p->next ) { if( strncmp( p->name,"irr_diag",8 ) ) { - for ( memb = p->members ; memb != NULL ; memb = memb->next ) - if ( strcmp(memb->name,"-") ) fprintf(fp," P_%s = 1 ; F_%s = .FALSE. \n", memb->name, memb->name ) ; + for ( memb = p->members ; memb != NULL ; memb = memb->next ) { + if ( strcmp(memb->name,"-") ) { + fprintf(fp," P_%s = 1 ; F_%s = .FALSE. \n", memb->name, memb->name); + } + } } } @@ -171,11 +187,11 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 ) fprintf(fp," P_%s = %s_index_table( PARAM_%s , idomain )\n",c,assoc_4d,c) ; fprintf(fp," END IF\n") ; { - char fourd_bnd[NAMELEN] ; + char fourd_bnd[NAMELEN_LONG + EXTRA_FOR_DEST_BUFFER] = { '\0' } ; /* check for the existence of a fourd boundary array associated with this 4D array */ /* set io_mask accordingly for gen_wrf_io to know that it should generate i/o for _b and _bt */ /* arrays */ - sprintf(fourd_bnd,"%s_b",assoc_4d) ; + sprintf(fourd_bnd, "%s_b",assoc_4d) ; if ( get_entry_r( fourd_bnd, NULL, Domain.fields) != NULL ) { x->boundary = 1 ; } diff --git a/tools/gen_streams.c b/tools/gen_streams.c index ad5251ff4d..a7e055413e 100644 --- a/tools/gen_streams.c +++ b/tools/gen_streams.c @@ -10,6 +10,25 @@ #include "data.h" #include "sym.h" +int gen_io_domain_defs ( FILE * fp ); +int gen_io_boilerplate (); +int gen_med_find_esmf_coupling ( FILE *fp ); +int gen_shutdown_closes ( FILE *fp ); +int gen_med_open_esmf_calls ( FILE *fp ); +int gen_med_last_solve_io ( FILE *fp ); +int gen_med_auxinput_in_closes ( FILE *fp ); +int gen_med_hist_out_closes ( FILE *fp ); +int gen_med_hist_out_opens ( FILE *fp ); +int gen_med_auxinput_in ( FILE *fp ); +int gen_fine_stream_input ( FILE *fp ); +int gen_check_auxstream_alarms ( FILE *fp ); +int gen_switches_and_alarms ( FILE *fp ); +int gen_io_form_for_stream ( FILE *fp ); +int gen_io_form_for_dataset ( FILE *fp ); +int gen_set_timekeeping_alarms ( FILE * fp ); +int gen_set_timekeeping_defs ( FILE *fp ); + + int gen_streams( char * dirname ) { FILE * fp ; @@ -160,7 +179,7 @@ gen_io_domain_defs ( FILE * fp ) for ( i = 0 ; i < 2*MAX_HISTORY ; i++ ) { if ( i % MAX_HISTORY == 0 ) { aux = "" ; streamno[0] = '\0' ; } - else { aux="aux" ; sprintf(streamno,"%d",i%MAX_HISTORY) ; } + else { aux="aux" ; sprintf(streamno,"%d",(signed char) i%MAX_HISTORY) ; } if ( i < MAX_HISTORY ) { streamtype = "input" ; } else { streamtype = ( i%MAX_HISTORY == 0 )?"history":"hist" ; } @@ -188,7 +207,7 @@ gen_set_timekeeping_defs ( FILE *fp ) for ( i = 0 ; i < 2*MAX_HISTORY ; i++ ) { if ( i % MAX_HISTORY == 0 ) { aux = "" ; streamno[0] = '\0' ; } - else { aux="aux" ; sprintf(streamno,"%d",i%MAX_HISTORY) ; } + else { aux="aux" ; sprintf(streamno,"%d",(signed char) i%MAX_HISTORY) ; } if ( i < MAX_HISTORY ) { streamtype = "input" ; } else { streamtype = ( i%MAX_HISTORY == 0 )?"history":"hist" ; } @@ -222,7 +241,7 @@ gen_set_timekeeping_alarms ( FILE * fp ) for ( i = 0 ; i < 2*MAX_HISTORY ; i++ ) { if ( i % MAX_HISTORY == 0 ) { aux = "" ; streamno[0] = '\0' ; } - else { aux="aux" ; sprintf(streamno,"%d",i%MAX_HISTORY) ; } + else { aux="aux" ; sprintf(streamno,"%d",(signed char) i%MAX_HISTORY) ; } if ( i < MAX_HISTORY ) { streamtype = "input" ; } else { streamtype = ( i%MAX_HISTORY == 0 )?"history":"hist" ; } if ( i == 0 ) continue ; /* skip just input */ @@ -305,7 +324,7 @@ int gen_io_form_for_dataset ( FILE *fp ) { char * aux , *streamtype , streamno[5] ; - int i ; + unsigned char i ; fprintf(fp," IF ( DataSet .eq. 'RESTART' ) THEN\n") ; fprintf(fp," CALL nl_get_io_form_restart( 1, io_form )\n") ; @@ -333,7 +352,7 @@ int gen_io_form_for_stream ( FILE *fp ) { char * aux , *streamtype , streamno[5] ; - int i ; + unsigned char i ; fprintf(fp," IF ( stream .eq. restart_only ) THEN\n") ; fprintf(fp," CALL nl_get_io_form_restart( 1, io_form )\n") ; diff --git a/tools/gen_wrf_io.c b/tools/gen_wrf_io.c index 87c539b6e0..89996f0b78 100644 --- a/tools/gen_wrf_io.c +++ b/tools/gen_wrf_io.c @@ -50,7 +50,7 @@ gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, no node_t * p ; int i , ii ; char x[NAMELEN], tag[NAMELEN], dexes[NAMELEN] ; - char dname[NAMELEN], dname_tmp[NAMELEN] ; + char dname[NAMELEN + EXTRA_FOR_DEST_BUFFER], dname_tmp[NAMELEN] ; char vname[NAMELEN], vname_x[NAMELEN],vname_1[NAMELEN], vname_2[NAMELEN], memord[NAMELEN] ; char ddim[3][2][NAMELEN] ; char mdim[3][2][NAMELEN] ; @@ -58,7 +58,7 @@ gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, no char ddim_no[3][2][NAMELEN] ; char mdim_no[3][2][NAMELEN] ; char pdim_no[3][2][NAMELEN] ; - char dimname[3][NAMELEN] ; + char dimname[3][NAMELEN + EXTRA_FOR_DEST_BUFFER] ; char stagstr[NAMELEN] ; char * tend_tag ; @@ -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 */ @@ -115,8 +115,8 @@ gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, no int ibdy ; int idx ; node_t *fourd_bound_array ; - char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ; - char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ; + char *bdytag="", *xdomainend="", *ydomainend="", *zdomainend="", bdytag2[10],fourd_bnd[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + char *ds1="",*de1="",*ds2="",*de2="",*ds3="",*de3="",*ms1="",*me1="",*ms2="",*me2="",*ms3="",*me3="",*ps1="",*pe1="",*ps2="",*pe2="",*ps3="",*pe3="" ; #if ( WRFPLUS == 1 ) /* adjoint and perturbation variables should not be inputed*/ @@ -276,12 +276,12 @@ fprintf(fp, "ENDDO\n") ; /* //////// BOUNDARY ///////////////////// */ - if ( p->boundary && strcmp( p->use, "_4d_bdy_array_" ) || ( p->boundary && fourdname ) ) + if ( (p->boundary && strcmp( p->use, "_4d_bdy_array_" )) || ( p->boundary && fourdname ) ) { int ibdy ; int idx ; - char *bdytag, *xdomainend, *ydomainend, *zdomainend ; - char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ; + char *bdytag="", *xdomainend="", *ydomainend="", *zdomainend="" ; + char *ds1="",*de1="",*ds2="",*de2="",*ds3="",*de3="",*ms1="",*me1="",*ms2="",*me2="",*ms3="",*me3="",*ps1="",*pe1="",*ps2="",*pe2="",*ps3="",*pe3="" ; char t1[64], t2[64] ; #if ( WRFPLUS == 1 ) diff --git a/tools/misc.c b/tools/misc.c index a794fd692a..79d2f7c736 100644 --- a/tools/misc.c +++ b/tools/misc.c @@ -17,7 +17,7 @@ char * dimension_with_colons( char * pre , char * tmp , node_t * p , char * post ) { - int i ; + unsigned int i ; if ( p == NULL ) return("") ; if ( p->ndims <= 0 && ! p->boundary_array ) return("") ; strcpy(tmp,"") ; @@ -44,8 +44,8 @@ dimension_with_colons( char * pre , char * tmp , node_t * p , char * post ) char * dimension_with_ones( char * pre , char * tmp , node_t * p , char * post ) { - int i ; - char r[NAMELEN],s[NAMELEN],four_d[NAMELEN] ; + unsigned int i ; + char r[NAMELEN + 2 * EXTRA_FOR_DEST_BUFFER],s[NAMELEN],four_d[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; char *pp ; if ( p == NULL ) return("") ; if ( p->ndims <= 0 && ! p->boundary_array ) return("") ; @@ -90,10 +90,10 @@ dimension_with_ranges( char * refarg , char * pre , which a namelist supplied dimension should be dereference from, or "" */ { - int i ; - char tx[NAMELEN] ; - char r[NAMELEN],s[NAMELEN],four_d[NAMELEN] ; - int bdex, xdex, ydex, zdex ; + unsigned int i ; + char tx[6 * (NAMELEN + EXTRA_FOR_DEST_BUFFER)] ; + char r[NAMELEN],s[NAMELEN],four_d[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + int bdex = 0, xdex, ydex, zdex ; node_t *xdim, *ydim, *zdim ; char *pp ; if ( p == NULL ) return("") ; @@ -180,11 +180,11 @@ char * index_with_firstelem( char * pre , char * dref , int bdy , /* as defined in data.h */ char * tmp , node_t * p , char * post ) { - int i ; - char tx[NAMELEN] ; + unsigned int i ; + char tx[NAMELEN * 3] = {'\0'} ; char tmp2[NAMELEN] ; /* SamT: bug fix: zdex is used but never set */ - int bdex, xdex, ydex, zdex=-999 ; + int bdex = 0, xdex, ydex, zdex=-999 ; node_t *xdim, *ydim, *zdim ; char r[NAMELEN] ; @@ -262,7 +262,7 @@ int get_elem ( char * structname , char * nlstructname , char * tx , int i , node_t * p , int first_last ) { char dref[NAMELEN], nlstruct[NAMELEN] ; - char d, d1 ; + char d, d1 = '\0' ; if ( structname == NULL ) { strcpy( dref, "" ) ;} else { strcpy( dref, structname ) ; } @@ -290,25 +290,27 @@ get_elem ( char * structname , char * nlstructname , char * tx , int i , node_t if ( p->dims[i]->subgrid ) { if ( first_last == 0 ) { /*first*/ - sprintf(tx,"(%ssm3%d%s-1)*%ssr_%c+1",dref,p->dims[i]->dim_order,ornt,dref,d1) ; + snprintf(tx, 3 * NAMELEN, "(%ssm3%d%s-1)*%ssr_%c+1",dref,p->dims[i]->dim_order,ornt,dref,d1) ; }else{ /*last*/ - sprintf(tx,"%sem3%d%s*%ssr_%c" ,dref,p->dims[i]->dim_order,ornt,dref,d1) ; + snprintf(tx, 3 * NAMELEN, "%sem3%d%s*%ssr_%c" ,dref,p->dims[i]->dim_order,ornt,dref,d1) ; } } else { - sprintf(tx,"%s%cm3%d%s",dref,first_last==0?'s':'e',p->dims[i]->dim_order,ornt) ; + snprintf(tx, 3 * NAMELEN, "%s%cm3%d%s",dref,first_last==0?'s':'e',p->dims[i]->dim_order,ornt) ; } } break ; case (NAMELIST) : - if ( first_last == 0 ) { if ( !strcmp( p->dims[i]->assoc_nl_var_s , "1" ) ) { - sprintf(tx,"%s",p->dims[i]->assoc_nl_var_s) ; - } else { - sprintf(tx,"%s%s%s",nlstructname,structname,p->dims[i]->assoc_nl_var_s) ; - } - } - else { sprintf(tx,"%s%s%s",nlstructname,structname,p->dims[i]->assoc_nl_var_e) ; } + if ( first_last == 0 ) { + if ( !strcmp( p->dims[i]->assoc_nl_var_s , "1" ) ) { + snprintf(tx, 3 * NAMELEN,"%s",p->dims[i]->assoc_nl_var_s) ; + } else { + snprintf(tx, 3 * NAMELEN, "%s%s%s",nlstructname,structname,p->dims[i]->assoc_nl_var_s) ; + } + } else { + snprintf(tx, 3 * NAMELEN, "%s%s%s",nlstructname,structname,p->dims[i]->assoc_nl_var_e) ; + } break ; case (CONSTANT) : if ( first_last == 0 ) { sprintf(tx,"%d",p->dims[i]->coord_start) ; } @@ -560,10 +562,10 @@ array_size_expression ( char * refarg , char * pre , which a namelist supplied dimension should be dereference from, or "" */ { - int i ; - char tx[NAMELEN] ; - char r[NAMELEN],s[NAMELEN],four_d[NAMELEN] ; - int bdex, xdex, ydex, zdex ; + unsigned int i ; + char tx[6 * (NAMELEN + EXTRA_FOR_DEST_BUFFER)] ; + char r[NAMELEN],s[NAMELEN],four_d[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + int bdex = 0, xdex, ydex, zdex ; node_t *xdim, *ydim, *zdim ; char *pp ; if ( p == NULL ) return("") ; diff --git a/tools/protos.h b/tools/protos.h index 3d39c2dfa7..85f72691da 100644 --- a/tools/protos.h +++ b/tools/protos.h @@ -4,7 +4,12 @@ int init_dim_table() ; int make_lower( char * s1 ) ; +char *make_lower_case ( char * str ) ; +char *make_upper_case ( char * str ) ; int reg_parse( FILE * infile ) ; +int init_parser() ; +int pre_parse( char * dir, FILE * infile, FILE * outfile ) ; +int check_dimspecs() ; int set_dim_len ( char * dimspec , node_t * dim_entry ) ; int set_dim_order ( char * dimorder , node_t * dim_entry ) ; int set_dim_orient ( char * dimorient , node_t * dim_entry ) ; @@ -71,16 +76,25 @@ char * get_typename_i(int i) ; int gen_alloc ( char * dirname ) ; int gen_alloc1 ( char * dirname ) ; int gen_alloc2 ( FILE * fp , char * structname , char * structname2 , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ); +int gen_comms ( char * dirname ); +int gen_streams( char * dirname ); +int gen_io_boilerplate (); int gen_module_state_description ( char * dirname ) ; int gen_module_state_description1 ( FILE * fp , node_t * node ) ; int gen_scalar_indices ( char * dirname ) ; int gen_scalar_indices1 ( FILE * fp, FILE ** fp2 ) ; +int gen_nest_interp ( char * dirname ); +int gen_nest_v_interp ( char * dirname ); +int gen_nest_interp2(FILE *fp, node_t *node, char *fourdname, int down_path, int use_nest_time_level); 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_dummy_decls ( char * dn ) ; +int gen_dummy_decls_new ( char * dn ) ; 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 ) ; @@ -108,6 +122,7 @@ int gen_wrf_io2 ( FILE * fp , char * fname , char * structname , char * fourdnam int gen_namelist_defines ( char * dirname , int sw_dimension ) ; int gen_namelist_defaults ( char * dirname ) ; int gen_namelist_script ( char * dirname ) ; +int gen_namelist_statements ( char * dirname ) ; int gen_model_data_ord ( char * dirname ) ; @@ -122,6 +137,9 @@ int range_of_dimension ( char *, char * , int, node_t *, char * ); int dimension_size_expression ( char *, char *, int, node_t *, char *); int gen_alloc_count ( char *); int gen_alloc_count1 ( char *); +int gen_comms ( char * dirname ); +int gen_streams( char * dirname ); +int gen_io_boilerplate (); int gen_ddt_write ( char * ); int gen_ddt_write1 ( FILE *, char *, node_t *); int gen_dealloc ( char * ); @@ -133,6 +151,7 @@ int irr_diag_scalar_indices ( char * ); int gen_scalar_tables_init ( FILE *); int gen_scalar_indices_init ( FILE *); int hash(char *); +int gen_nest_interp ( char * dirname ); int gen_nest_interp1 ( FILE *, node_t *, char *, int, int ); #if ( WRFPLUS == 1 ) int 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 /* 1 for ARW, varies for NMM */ ); diff --git a/tools/reg_parse.c b/tools/reg_parse.c index 8e2e1a0fd1..b40e7cfb13 100644 --- a/tools/reg_parse.c +++ b/tools/reg_parse.c @@ -85,22 +85,23 @@ #define COMM_USE 2 #define COMM_DEFINE 3 -static int ntracers = 0 ; +static unsigned int ntracers = 0 ; static char tracers[1000][100] ; int pre_parse( char * dir, FILE * infile, FILE * outfile ) { /* Decreased size for SOA from 8192 to 8000--double check if necessary, Manish Shrivastava 2010 */ - char inln[8000], parseline[8000], parseline_save[8000] ; + char inln[8000], parseline[8000] = {'\0'}, parseline_save[8000] ; int found ; char *p, *q ; char *tokens[MAXTOKENS], *toktmp[MAXTOKENS], newdims[NAMELEN_LONG], newdims4d[NAMELEN_LONG],newname[NAMELEN_LONG] ; - int i, ii, len_of_tok ; + unsigned int i, ii; + ssize_t len_of_tok = 0; char x, xstr[NAMELEN_LONG] ; - int is4d, wantstend, wantsbdy ; - int ifdef_stack_ptr = 0 ; - int ifdef_stack[100] ; + unsigned char is4d = 0, wantstend = 0, wantsbdy = 0 ; + signed char ifdef_stack_ptr = 0 ; + int ifdef_stack[100] = {1} ; int inquote, retval ; ifdef_stack[0] = 1 ; @@ -117,21 +118,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[128] ; + char include_file_name_local_registry[NAMELEN + EXTRA_FOR_DEST_BUFFER] ; + char include_file_name[2 * NAMELEN + EXTRA_FOR_DEST_BUFFER] ; 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 ) ; } } } @@ -140,7 +150,13 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) p += 5 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; strncpy(value, p, 31 ) ; value[31] = '\0' ; if ( (p=index(value,'\n')) != NULL ) *p = '\0' ; - if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,' ')) != NULL ) *p = '\0' ; + /* I have no clue what the next line was trying to say */ + if ( (p=index(value,' ')) != NULL ) { + *p = '\0' ; + } + if ( (p=index(value,' ')) != NULL ) { + *p = '\0' ; + } ifdef_stack_ptr++ ; ifdef_stack[ifdef_stack_ptr] = ( sym_get(value) != NULL && ifdef_stack[ifdef_stack_ptr-1] ) ; if ( ifdef_stack_ptr >= 100 ) { fprintf(stderr,"Registry fatal: too many nested ifdefs\n") ; exit(1) ; } @@ -151,7 +167,13 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) p += 6 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; strncpy(value, p, 31 ) ; value[31] = '\0' ; if ( (p=index(value,'\n')) != NULL ) *p = '\0' ; - if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,' ')) != NULL ) *p = '\0' ; + /* I have no idea what the next line was trying to accomplish */ + if ( (p=index(value,' ')) != NULL ) { + *p = '\0' ; + } + if ( (p=index(value,' ')) != NULL ) { + *p = '\0' ; + } ifdef_stack_ptr++ ; ifdef_stack[ifdef_stack_ptr] = ( sym_get(value) == NULL && ifdef_stack[ifdef_stack_ptr-1] ) ; if ( ifdef_stack_ptr >= 100 ) { fprintf(stderr,"Registry fatal: too many nested ifdefs\n") ; exit(1) ; } @@ -167,7 +189,13 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) p += 6 ; for ( ; ( *p == ' ' || *p == ' ' ) && *p != '\0' ; p++ ) ; strncpy(value, p, 31 ) ; value[31] = '\0' ; if ( (p=index(value,'\n')) != NULL ) *p = '\0' ; - if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,' ')) != NULL ) *p = '\0' ; + /* Another instance of this distinctly odd pattern */ + if ( (p=index(value,' ')) != NULL ) { + *p = '\0' ; + } + if ( (p=index(value,' ')) != NULL ) { + *p = '\0' ; + } sym_add( value ) ; continue ; } @@ -237,7 +265,7 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) } sprintf(xstr,"%c",x) ; if ( x != 'b' || inbrace ) strcat ( newdims , xstr ) ; - if ( x != 'f' && x != 't' || inbrace ) strcat( newdims4d , xstr ) ; + if ( (x != 'f' && x != 't') || inbrace ) strcat( newdims4d , xstr ) ; } if ( wantsbdy ) { @@ -256,7 +284,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]) ; + strncpy(tracers[ntracers], tokens[F_USE], 100); ntracers++ ; /* add entries for _b and _bt arrays */ @@ -306,7 +334,8 @@ reg_parse( FILE * infile ) char inln[7000], parseline[7000] ; char *p, *q ; char *tokens[MAXTOKENS], *toktmp[MAXTOKENS] ; - int i, ii, idim ; + unsigned int i, ii; + int idim ; int defining_state_field, defining_rconfig_field, defining_i1_field ; parseline[0] = '\0' ; @@ -478,7 +507,7 @@ reg_parse( FILE * infile ) char prev = '\0' ; char x ; char tmp[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ; - int len_of_tok ; + ssize_t len_of_tok = 0 ; char fcn_name[2048], aux_fields[2048] ; strcpy(tmp,tokens[FIELD_IO]) ; @@ -509,7 +538,7 @@ reg_parse( FILE * infile ) if (( pp = index(tmp2,'}') ) != NULL ) { *pp = '\0' ; unitid = atoi(tmp2) ; /* JM 20100416 */ - if ( unitid >= 0 || unitid < MAX_STREAMS && stream + unitid < MAX_HISTORY ) { + if ( unitid >= 0 || (unitid < MAX_STREAMS && stream + unitid < MAX_HISTORY) ) { set_mask( mask , stream + unitid ) ; } p = p + strlen(tmp2) + 1 ; @@ -536,7 +565,7 @@ reg_parse( FILE * infile ) *pp = '\0' ; iii = pp - (tmp + i + 1) ; unitid = atoi(tmp+i+1) ; /* JM 20091102 */ - if ( unitid >= 0 || unitid < MAX_STREAMS && unitid < MAX_HISTORY ) { + if ( unitid >= 0 || (unitid < MAX_STREAMS && unitid < MAX_HISTORY) ) { if ( prev == 'i' ) { set_mask( field_struct->io_mask , unitid + MAX_HISTORY ) ; } else if ( prev == 'h' ) { @@ -567,7 +596,8 @@ reg_parse( FILE * infile ) if ( tokens[FIELD_IO][i+1] == '=' ) { - int ii, jj, state ; + unsigned int ii; + int jj, state ; state = 0 ; jj = 0 ; for ( ii = i+3 ; ii < len_of_tok ; ii++ ) @@ -1058,7 +1088,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 ) ; @@ -1083,7 +1113,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..45a8bb14ec 100644 --- a/tools/registry.c +++ b/tools/registry.c @@ -1,16 +1,17 @@ #include #include -#ifdef _WIN32 +#if defined(_WIN32) || defined(__CYGWIN__) # include +#endif +#ifdef _WIN32 # define rindex(X,Y) strrchr(X,Y) # define index(X,Y) strchr(X,Y) -#else +#endif # include # include # include # include # include -#endif #define DEFINE_GLOBALS #include "protos.h" @@ -18,15 +19,19 @@ #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[] ) +main( int argc, char *argv[] ) { - char fname_in[NAMELEN], dir[NAMELEN], fname_tmp[NAMELEN], command[NAMELEN] ; - char fname_wrk[NAMELEN] ; + char fname_in[NAMELEN] = {'\0'}, dir[NAMELEN] = {'\0'}; + char fname_tmp[NAMELEN] = {'\0'}, command[2 * (NAMELEN + EXTRA_FOR_DEST_BUFFER)] = {'\0'}; + char fname_wrk[NAMELEN + EXTRA_FOR_DEST_BUFFER] = {'\0'}; FILE * fp_in, *fp_tmp ; - char * thisprog ; - char *env_val ; + char * thisprog = ""; + char *env_val = ""; int mypid ; int do_irr_diag ; #ifndef _WIN32 @@ -34,7 +39,7 @@ main( int argc, char *argv[], char *env[] ) #endif mypid = (int) getpid() ; - strcpy( thiscom, argv[0] ) ; + strncpy( thiscom, argv[0], 4 * NAMELEN - 1) ; argv++ ; sw_deref_kludge = 0 ; @@ -132,11 +137,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? // @@ -157,7 +162,8 @@ main( int argc, char *argv[], char *env[] ) sprintf( fname_wrk,"%s/Registry_irr_diag",dir ) ; } // fprintf(stderr,"Registry tmp file = %s\n",fname_wrk); - sprintf(command,"/bin/cp %s %s\n",fname_in,fname_wrk); + /* we should be able to implement this using posix_spawn */ + sprintf(command,"/bin/cp \'%s\' \'%s\'\n",fname_in,fname_wrk); // fprintf(stderr,"Command = %s\n",command); if( system( command ) ) { fprintf(stderr,"Could not copy %s to %s\n",fname_in,fname_wrk); @@ -230,45 +236,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 @@ -279,10 +285,10 @@ main( int argc, char *argv[], char *env[] ) sprintf(command,"del /F /Q %s\n",fname_tmp ); #else if( do_irr_diag ) { - sprintf(command,"/bin/rm -f %s\n",fname_wrk ); + sprintf(command,"/bin/rm -f \'%s\'\n",fname_wrk ); system( command ) ; } - sprintf(command,"/bin/rm -f %s\n",fname_tmp ); + sprintf(command,"/bin/rm -f \'%s\'\n",fname_tmp ); #endif return system( command ) ; } diff --git a/tools/registry.h b/tools/registry.h index 0a2e627ffd..983aaff8a4 100644 --- a/tools/registry.h +++ b/tools/registry.h @@ -1,6 +1,12 @@ #ifndef REGISTRY_H +#include +#include +#include + #define NAMELEN 512 #define NAMELEN_LONG 125000 +#define EXTRA_FOR_DEST_BUFFER 20 + #define MAXDIMS 21 #define MAX_DYNCORES 50 /* ha ha, just kidding */ /* #define MAX_ARGLINE 175 WRF uses 128 by default, but the nested chem version hit the continuation line limit for efc so it had to be increased, wig 14-Oct-2004 */ diff --git a/tools/set_dim_strs.c b/tools/set_dim_strs.c index 91d75b127c..491ffd8702 100644 --- a/tools/set_dim_strs.c +++ b/tools/set_dim_strs.c @@ -18,7 +18,7 @@ set_dim_strs_x ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELE { int i, j, ii ; node_t *p ; - char d, d1 ; + char d = '\0', d1 = '\0' ; char * stag ; char r1[NAMELEN] ; diff --git a/tools/sym.h b/tools/sym.h index 5480b9d908..75e7bb22bd 100644 --- a/tools/sym.h +++ b/tools/sym.h @@ -55,6 +55,7 @@ ***************************************************************************/ #ifndef SYM_H #define SYM_H +#include /* file: sym.h diff --git a/tools/symtab_gen.c b/tools/symtab_gen.c index a6ddcf9661..4ea58d5171 100644 --- a/tools/symtab_gen.c +++ b/tools/symtab_gen.c @@ -41,6 +41,9 @@ For a sample main or calling program see the end of this file. #define HASHSIZE 1024 +#include "sym.h" +int hash(char * name); + /* commented out 2-29-90 static char * symtab[HASHSIZE] ; */ @@ -49,7 +52,7 @@ void * malloc() ; void * calloc() ; */ -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 */ +sym_nodeptr 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 ; @@ -90,7 +93,7 @@ char * symget(char *name,char *(*newnode)(),char **(*nodename)(char *),char **(* } } - return(p) ; + return ((sym_nodeptr) p) ; } int hash(char * name ) diff --git a/tools/type.c b/tools/type.c index 0ef42c74d1..e40d4ef7c1 100644 --- a/tools/type.c +++ b/tools/type.c @@ -230,7 +230,7 @@ get_entry_r ( char * name , char * use , node_t * node ) node_t * get_dimnode_for_coord ( node_t * node , int coord_axis ) { - int i ; + unsigned int i ; if ( node == NULL ) return(NULL) ; for ( i = 0 ; i < node->ndims ; i++ ) { @@ -246,7 +246,7 @@ get_dimnode_for_coord ( node_t * node , int coord_axis ) int get_index_for_coord ( node_t * node , int coord_axis ) { - int i ; + unsigned int i ; if ( node == NULL ) return( -1 ) ; for ( i = 0 ; i < node->ndims ; i++ ) { @@ -263,7 +263,7 @@ get_index_for_coord ( node_t * node , int coord_axis ) char * set_mem_order( node_t * node , char * str , int n ) { - int i ; + unsigned int i ; node_t * p ; if ( str == NULL || node == NULL ) return(NULL) ; 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, &